expm/0000755000176200001440000000000014547745062011241 5ustar liggesusersexpm/NAMESPACE0000644000176200001440000000133412605211701012436 0ustar liggesusers### C code useDynLib(expm, .registration = TRUE) importFrom("methods", as, is) importFrom("stats", rnorm) importFrom("Matrix", Schur, norm, solve,# <- for expm.Higham08(*, balancing=FALSE) rowSums, colSums,# e.g. in expm.s.Pade.s Diagonal, Matrix)# <- only in Schur(Matrix(.)) ### Exports export(expm, expAtv) export("%^%") export(balance, dgebal)# dgebal() should become deprecated -- see R/dgebal.R and ./TODO export(logm) ## From Michael Stadelmann's (ETH Zurich) Master Thesis : ------------ export(expm.Higham08)## exported, as has own help == man/expm.Higham08.Rd ## For now we want the files to be kept modularly separate from the rest of 'expm' export(expmCond, expmFrechet) export(sqrtm) expm/demo/0000755000176200001440000000000014547731235012162 5ustar liggesusersexpm/demo/balanceTst.R0000644000176200001440000001016213777072735014374 0ustar liggesusersbalanceTst <- function(A) { ## Purpose: Consistency checking of balance() {was "dgebal()"} ## ---------------------------------------------------------------------- ## Arguments: a square matrix ## ---------------------------------------------------------------------- ## Author: Martin Maechler, 20 Feb 2008 and on n <- dim(A)[1] ## do *the* three calls and look at result P <- balance(A, "P") doPerm <- function(A, pp, i1, i2) { stopifnot(length(pp) == n, dim(A) == c(n,n), 1 <= i1, i1 <= i2, i2 <= n) A. <- A if(i2 < n) { ## The upper part for(i in n:(i2+1)) { # 'p2' in *reverse* order ## swap i <-> pp[i] both rows and columns tt <- A.[,i]; A.[,i] <- A.[,pp[i]]; A.[,pp[i]] <- tt tt <- A.[i,]; A.[i,] <- A.[pp[i],]; A.[pp[i],] <- tt } } if(i1 > 1) { ## The lower part for(i in 1:(i1-1)) { # 'p1' in *forward* order tt <- A.[,i]; A.[,i] <- A.[,pp[i]]; A.[,pp[i]] <- tt tt <- A.[i,]; A.[i,] <- A.[pp[i],]; A.[pp[i],] <- tt } } A. } checkPerm <- function(P, orig.A) { didPerm <- ((leftP <- (i1 <- P$i1) != 1L) | (rightP <- (i2 <- P$i2) != n)) if(didPerm) { ## *had* permutation -- now check my idea about it pp <- as.integer(P$scale) ## Permute A to become P$z : A. <- doPerm(orig.A, pp = pp, i1=i1, i2=i2) stopifnot(isTRUE(all.equal(A., P$z, tolerance = 1e-15))) ## Now the reverse: Use pp[] and permute A. "back to A": if(leftP) { ## The lower part for(i in (i1-1):1) { # 'p1' in *reverse* order tt <- A.[,i]; A.[,i] <- A.[,pp[i]]; A.[,pp[i]] <- tt tt <- A.[i,]; A.[i,] <- A.[pp[i],]; A.[pp[i],] <- tt } } if(rightP) { ## The upper part for(i in (i2+1):n) { # 'p2' in *forward* order ## swap i <-> pp[i] both rows and columns tt <- A.[,i]; A.[,i] <- A.[,pp[i]]; A.[,pp[i]] <- tt tt <- A.[i,]; A.[i,] <- A.[pp[i],]; A.[pp[i],] <- tt } } stopifnot(isTRUE(all.equal(A., orig.A, tolerance = 1e-15))) } } checkPerm(P, orig.A = A) S <- balance(P$z, "S")# "S" starting from result of "P" stopifnot(S$i1 == 1, S$i2 == n) ## Now check the scaling checkScal <- function (d, A1, A2) { stopifnot(length(d) == n, dim(A1) == dim(A2), dim(A2) == c(n,n)) ## A.scaled <- diag(1/d, n) \%*\% A1 \%*\% diag(d, n) ## more efficiently: A.scaled <- A1 * (rep(d, each = n) / d) stopifnot(isTRUE(all.equal(A2, A.scaled, tolerance = 1e-15))) ## Check the reverse: S.rescaled <- A2 * (d * rep(1/d, each = n)) stopifnot(isTRUE(all.equal(A1, S.rescaled, tolerance = 1e-15))) } checkScal(d = S$scale, A1 = P$z, A2 = S$z) B <- balance(A, "B")# "B" : B[oth] stopifnot(P$i1 == B$i1, P$i2 == B$i2) ## now check *both* permutation and scaling A.perm <- doPerm(A, pp = as.integer(B$scale), i1=B$i1, i2=B$i2) ## checkPerm(B, orig.A = A) dB <- B$scale dB[c(if(B$i1 > 1) 1:(B$i1-1), if(B$i2 < n) (B$i2+1):n)] <- 1 checkScal(d = dB, A1 = A.perm, A2 = B$z) ## return list(P = P, S = S, B = B, Sz.eq.Bz = isTRUE(all.equal(S$z, B$z))) } m4. <- rbind(c(-1,-2, 0, 0), c( 0, 0,10,11), c( 0, 0,12, 0), c( 0,13, 0, 0)) str(b4. <- balanceTst(m4.)) ## better (?) example (m <- matrix(c(0,-1,0,-2,10, rep(0,11)), 4,4)) str(ba <- balanceTst(m)) ## Hmm: here S$z *differs* from B$z ## --- but at least, the scale[] and z[] returned seem ok ## a non-empty ``less-balanced'' example --- m4 <- matrix(outer(2^(0:7),c(-1,1)), 4,4) m4[lower.tri(m4)] <- 0 #--> upper triangular ==> will have many permutations ## now permute it; so balance() will find the permutation p <- c(4,2:1,3); m4 <- m4[p,p] m4 str(dm4 <- balanceTst(m4)) # much permutation! i1 = i2 = 1 ! expm/demo/exact-fn.R0000644000176200001440000001057012311702321013772 0ustar liggesusers#### "demo": Make these (function) definitions easily available to useRs #### ---- --> we use them in tests in ../tests/exact-ex.R ## ~~~~~~~~~~~~~~~~~~~ ### For nilpotent matrices A, exp(A) is polynomial in A ### Mathworld gives the example of the general 3 x 3 upper triangle nilA3 <- function(x,y,z) { ## Purpose: simple nilpotent matrix 3x3 A (with A^n = 0 for n >= 3) ## / 0 x z \ ## A = [ 0 0 y ] ## \ 0 0 0 / ## and its exact matrix exponential ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 19 Jan 2008 stopifnot((n <- length(x)) == 1, length(y) == 1, length(z) == 1, is.numeric(x), is.numeric(y), is.numeric(z)) list(A = cbind(0, rbind(matrix(c(x,0,z,y), 2,2), 0)), expA = cbind(c(1,0,0), c(x,1,0), c(z + x*y/2, y, 1))) } ## Note that relErr() is copy-pasted from ../inst/test-tools.R : ## ## The relative error typically returned by all.equal: relErr <- function(target, current) mean(abs(target - current)) / mean(abs(target)) facMat <- function(n, R_FUN, ev = R_FUN(n), M = rMat(n, R_FUN = R_FUN)) { ## Purpose: Construct random matrix x of which we "know" expm(x) ## because we set x := M %*% diag(ev) %*% solve(M) ## ---------------------------------------------------------------------- ## Arguments: n: dimension of matrices ## R_FUN: random number generator function (n) ## ev: numeric length-n vector of eigenvalues ## M: n x n matrix. Note that the default, ## rMat() will give matrices ``not close to singular'' ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: Feb 2008 R_FUN <- match.fun(R_FUN) stopifnot(n > 0, is.numeric(ev), length(ev) == n, dim(M) == c(n,n), is.numeric(M)) iM <- solve(M) ## D <- diag(ev); A = M %*% D %*% iM list(A = M %*% (ev * iM), expA = M %*% (exp(ev) * iM)) } ### --- The 2x2 example with bad condition , see A3 in ./ex2.R m2ex3 <- function(eps = 0) { stopifnot(is.numeric(eps), length(eps) == 1) A <- rbind(c(-1, 1), c(eps^2, -1)) I.e <- 1 - eps^2 / 2 V <- I.e* rbind( c(-1, 1), eps*c( 1, 1)) D <- c(-1-eps, -1+eps) iV <- ## solve(V) rbind(c(-1, 1/eps), c( 1, 1/eps)) / (2 * I.e) ## NOTE: kappa(V) = condition_number(V) == 1/eps exactly useTol <- 2e-16 / eps stopifnot(all.equal(diag(2), V %*% iV, tolerance=useTol), all.equal(A, V %*% diag(D) %*% iV, tolerance=useTol) ) ch.e <- cosh(eps) sh.e <- sinh(eps) list(A = A, expA = exp(-1) * rbind(c( ch.e, sh.e/eps), c(sh.e*eps, ch.e ))) } ###--- rnilMat <- function(n, R_FUN = function(n) rpois(n, lambda=5)) { ## random upper triangular (zero-diagonal) nilpotent n x n matrix m <- matrix(0, n,n) ut <- upper.tri(m) R_FUN <- match.fun(R_FUN) m[ut] <- R_FUN(sum(ut)) m } set.seed(17) m <- rnilMat(10) if(FALSE) Matrix(m) ## 10 x 10 sparse Matrix of class "dtCMatrix" ## ## . 3 10 7 3 4 9 5 9 6 ## . . 5 4 3 . 5 6 3 6 ## . . . 5 7 7 3 7 5 6 ## . . . . 3 7 6 8 2 7 ## . . . . . 9 5 2 7 6 ## . . . . . . 8 5 4 6 ## . . . . . . . 5 5 3 ## . . . . . . . . 3 5 ## . . . . . . . . . 3 ## . . . . . . . . . . ## An interesting example, rounded from above {see ../tests/exact-ex.R} : dN <- 9*7*320 # 20160 EmN <- matrix(c(dN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3*dN, dN, 0, 0, 0, 0, 0, 0, 0, 0, 352800, 5*dN, dN, 0, 0, 0, 0, 0, 0, 0, 1018080, 332640, 5*dN, dN, 0, 0, 0, 0, 0, 0, 2235240, 786240, 292320, 3*dN, dN, 0, 0, 0, 0, 0, 9368520, 3483480, 1582560, 413280, 181440, dN, 0, 0, 0, 0, 24676176, 9598680, 5073600, 1562400, 826560, 161280, dN, 0,0,0, 43730160, 17451000, 10051440, 3430560, 1955520, 504000, 5*dN, dN, 0, 0, 68438436, 27747480, 16853760, 6036240, 3638880, 1038240, 252000, 3*dN, dN, 0, 119725855, 49165892, 31046760, 11652480, 7198800, 2264640, 614880, 191520, 3*dN, dN), 10, 10) xct10 <- list(m = m, expm = EmN / dN, expmNum = EmN, expmDen = dN) expm/demo/expm.R0000644000176200001440000000072712311702321013241 0ustar liggesusersrequire("expm") #diagonalisable matrix T <- cbind(c(-2, -3, 2), c(2, -2, 1), c(0, 2, -2)) expm(T) # numerically singular matrix T <- cbind(c(-2, 0, 0), c(2, -2, 0), c(0, 2, -2)) expm(T) #solve shows T is numerically singular try(solve(eigen(T)$vectors)) #singular matrix T <- cbind(c(0, 0, 0), c(2, 0, 0), c(1, 2, 0)) expm(T) stopifnot(all.equal(logm(expm(T)), T)) ## and show how close it is all.equal(logm(expm(T)), T, tolerance=0)# 2.39e-15 {64b ubuntu 12-04} expm/demo/00Index0000644000176200001440000000023711656206117013310 0ustar liggesusersexpm matrix exponential balanceTst Exploring balance(), i.e., LAPACK's dgeBAL matrix balancing exact-fn Functions for examples with exactly known solution expm/ChangeLog0000644000176200001440000002204014547727173013014 0ustar liggesusers2024-01-11 Martin Maechler * DESCRIPTION (Version): 0.999-9 * ... Matrix 1.6-5... needs to change a test !! 2023-11-28 Martin Maechler * DESCRIPTION (Version): 0.999-8 * tests/ex.R: ATLAS (Fedora 36, BDR) much less accurate -> using 'tol1' * src/R_dgebal.c (R_dgebal): fixed `error()` thinko. * man/expm.Higham08.Rd: Rd fixes. 2022-12-30 Martin Maechler * DESCRIPTION (Authors@): added, including ORCID for the 3 authors 2022-12-21 Martin Maechler * DESCRIPTION (Version): 0.999-7 * tests/ex.R: needed updates because ATLAS got precision deteriorated (!) 2021-08-19 Martin Maechler * po/*, inst/po/*, R/*.R: more translations and small fixes. 2021-01-12 Martin Maechler * man/*.Rd: updates to \url{}s. 2021-01-11 Martin Maechler * tests/ex.R: raise one tolerance (for "M1 mac"). 2020-07-21 Martin Maechler * DESCRIPTION (Version): 0.999-6 * R/balance.R (balance): now coerces to "matrix". Also, 'dgebal()' is finally deprecated *formally* (the help had: "balance()" is preferred nowadays, where "dgebal" will probably become deprecated since 2011). * demo/balanceTst.R (balanceTst): use balance(), not dgebal() * tests/exact-ex.R: test that more expm(*, method=".") methods work with sparse matrix. 2020-07-16 Martin Maechler * DESCRIPTION (Version): 0.999-5 * src/expm.h: add USE_FC_LEN_T and "FCONE" --> for LTO-compliant BLAS/Lapack * src/*.c: use "expm.h" even more; use FCONE for LTO-compliance 2019-03-20 Martin Mächler * DESCRIPTION (Version): 0.999-4 * src/R_NLS_locale.h renamed from ../locale.h helping wrongly configured compiler|preprocessort setups. * src/expm.h, etc: use "R_NLS_locale.h" 2018-09-15 Martin Mächler * man/logm.Rd: use try(.) [for solaris where needed] 2017-04-06 Martin Maechler * DESCRIPTION (Version): 0.999-3 * src/expm-eigen.c (do_expm_eigen): fix possible PROTECT stack imbalance * src/expm.c (do_expm): ditto; both thanks to T.Kalibera's `expm.so.bcheck` 2017-03-28 Martin Maechler * R/sqrtm.R (sqrtm): simple modification so it works for 1x1 matrix * R/logm.Higham08.R (rootS): (ditto) * src/init.c: "finish" registration 2016-12-13 Martin Maechler * DESCRIPTION (Version): 0.999-1 * src/matpow.c (matpow): use size_t etc, trying to prevent integer overflow when n^2 > .Machine$integer.max, i.e., n >= 46341 2015-10-06 Martin Maechler * DESCRIPTION (Version): 0.999-0 * R/balance.R (balance): also add 'job = "N"' (i.e., 'none') option. * src/R_dgebal.c (R_dgebal): catch +/-Inf in matrix avoiding infinite loop in Lapack's DGEBAL(); thanks to Terry Thernau. 2014-09-11 Martin Maechler * NAMESPACE: no longer export logm.Higham08 * R/expm2.R (expm.AlMoHi09): new expm(x, method = "AlMohy-Hi09") * src/matexp_MH09.c: thanks to Drew Schmidt. 2014-09-03 Martin Maechler * src/matpow.c: need to carefully REPROTECT x_ 2011-11-08 Martin Maechler * man/balance.Rd: use new name balance() instead of dgebal() * R/balance.R: 2011-10-28 Martin Maechler * src/matexp.f (matexpRBS): do not call STOP .. * NAMESPACE: import rowSums from Matrix (because of its sparseMatrix method). * R/expm.R (expm): auto-coerce sparse matrices to dense, when "needed". 2011-10-27 Martin Maechler * R/expm_vec.R (expAtv): finally add the functionality for 'exp(A*t) %*% v' Ravi had translated from EXPOKIT in August. 2011-08-27 Martin Maechler * R/expm.R (expm): add new method "PadeRBS" (Roger B. Sidje), interfacing to the corresponding Fortran code. * src/init.c, src/expm.h: also namespace-ify the Fortran symbols. 2011-08-26 Martin Maechler * NAMESPACE: also import solve() from Matrix, for sparse expm() 2011-03-30 Martin Maechler * DESCRIPTION (Version): 0.98-4 (Suggests): RColorBrewer, sfsmisc -- used in examples * inst/doc/expm.Rnw: replace the few non-ASCII chars by LaTeX. 2010-08-12 Martin Maechler * R/logm.Higham08.R (logm.Higham08): force argument to Schur(.) to be dense for now (working around infelicitous Matrix method). (logm.Higham08): catch case of infinite loop * man/logm.Rd: add example of the above. 2010-07-19 Martin Maechler * DESCRIPTION (Version): 0.98-2 * src/matpow.c (R_matpow): fix modify-argument bug in %^%. Thanks to stackflow-user "gd047" for reporting it. 2010-07-08 Martin Maechler * DESCRIPTION (Version): 0.98-1, for (first!) release to CRAN 2009-06-06 Martin Maechler * DESCRIPTION (Version): 0.96-2 * tests/exact-ex.R: adapt last test, to also pass on 32-bit Mac OSX 2009-06-02 Martin Maechler * tests/exact-ex.R: move print() to see Mac OSX error 2009-03-02 Martin Maechler * R/sqrtm.R (sqrtm): allow negative eigenvalues, with a message iff "verbose"; use sqrt() in that case. * R/logm.Higham08.R (logm.Higham08): allow negative eigenvalues, as in sqrtm. * R/expmCond-all.R (.expmCond.1, .expmFrechet2008.26): and others; cosmetic (speedy!) improvements; dating of Feb.23. 2009-02-28 Martin Maechler * DESCRIPTION (Version, Depends): 0.96-1, Matrix * src/logm-eigen.c (logm_eigen): *do* signal an error, not just print; as the help page has always said. * man/logm.Rd: comment 'order' and 'trySym' out; introduce method = "Higham08" and make it the default (!) * R/logm.R: ditto * R/logm.Higham08.R: new logm.Higham08() from Michael Stadelmann's thesis. * R/sqrtm.R: new sqrtm(), ditto * NAMESPACE: add here. * tests/log+sqrt.R: tests for these; notably small non-diagonalizable cases * R/expm2.R (expm.Higham08): renamed 'expm2' to expm.Higham08 2009-02-19 Martin Maechler * DESCRIPTION (Version): 0.95-1 * R/expmCond-all.R: only public expmCond(*, method=.) function, instead of expmCond1Est() etc. * man/expmCond.Rd: ditto * tests/expm-Cond.R: ditto 2009-02-19 Martin Maechler * DESCRIPTION (Maintainer): myself, for the moment; need to get E-mail feedback from win-builder. * tests/expm-Cond.R: new tests for expmCond*() * tests/exact-ex.R: factor the utilities out into new file; add expm2() * demo/exact-fn.R: containing only (function + data) definitions 2009-02-18 Martin Maechler * R/expmCond-all.R (expmFrechet): method "blockEnlarge", also for testing * man/expmFrechet.Rd: the default method 2009-02-17 Martin Maechler * DESCRIPTION (Version): 0.95-0 * R/expm2.R (expm2): new algorithms from Michael Stadelmann's Master thesis work * R/expmCond-all.R (expmCond, ..): Exponential Condition Number estimation * man/expm2.Rd, man/expmCond.Rd, man/expmFrechet.Rd: docu * NAMESPACE: export new functions 2009-01-30 Martin Maechler * src/R_dgebal.c (R_dgebal): fix to work also for integer matrix() * src/expm.c (do_expm), * src/expm-eigen.c (do_expm_eigen): ditto * tests/bal-ex.R: and test for it. 2008-05-13 Christophe Dutang * Use Lapack function zgecon in "hybrid_Eigen_Ward" to test the singularity. * Start the matrix logarithm logm. 2008-03-20 Vincent Goulet * New function matpow() as alias to operator %^%. * R/matpow.R: miscellaneous fixes and prettyfication of comments 2008-03-01 Martin Maechler * R/expm.R (expm): rename "Eigen" to "R_Eigen" * src/expm.c (expm): get "1bal" case right. * tests/compare-bal-expm.R: minimal testing of "2bal" vs "1bal" 2008-02-29 Martin Maechler * src/expm.c (expm): second argument 'precond_kind' * src/expm.h: update for new second argument * src/expm-eigen.h: implement workaround for Lapack.h's zlange() typo 2008-02-27 Martin Maechler * DESCRIPTION (Version): 0.9-1 -- new version for the occasion * src/expm.c (expm): HOORAY !! --- fixed the octave bug: using simpler __ and correct __ code for back-permuting * R/expm.R (expm): add method = "R_Ward77" which works *correctly* ! 2008-02-25 Martin Maechler * R/matpower.R ("%^%"): add R interface to * src/matpow.c 2008-02-23 Martin Maechler * R/expm.R (expm): add methods from David Firth's "mexp" and my modifications, of Fortran code in * src/mexp-common.f * src/matrexp.f * src/matrexpO.f expm/data/0000755000176200001440000000000014547731235012147 5ustar liggesusersexpm/data/matStig.R0000644000176200001440000000074010760040026013663 0ustar liggesusersmatStig <- matrix(c( 1.725, -0.765, -15.00, 0, 0, 0, 0, 0, -0.795, 0.765, 0, 0, 0, 0, 0, 0, 0, 0, 0.3949, -0.3949, 0, 0, 343.4851, 0, 0, 0, 0, 0.1456, 0, 0, 0, 0, 0, 0, 0, 0, -1.725, 0.795, 0, 0, 0, 0, 0, 0, 0.765,-0.765, 0, 0, 0, 0, 0, 0, 15.00, 0, -0.3949, 0, 0, 0, 0, 0, 0, 0, 0.3949, -0.1456), nrow=8, byrow=TRUE) expm/man/0000755000176200001440000000000014547731235012011 5ustar liggesusersexpm/man/expmFrechet.Rd0000644000176200001440000000447113044611522014543 0ustar liggesusers\name{expmFrechet} \title{Frechet Derivative of the Matrix Exponential} \alias{expmFrechet} \encoding{UTF-8} \description{ Compute the Frechet (actually \sQuote{Fréchet}) derivative of the matrix exponential operator. } \usage{ expmFrechet(A, E, method = c("SPS", "blockEnlarge"), expm = TRUE) } \arguments{ \item{A}{square matrix (\eqn{n \times n}{n x n}).} \item{E}{the \dQuote{small Error} matrix, used in \eqn{L(A,E) = f(A + E, A)}}%% FIXME \item{method}{string specifying the method / algorithm; the default \code{"SPS"} is \dQuote{Scaling + Pade + Squaring} as in the algorithm 6.4 below; otherwise see the \sQuote{Details} section.} \item{expm}{logical indicating if the matrix exponential itself, which is computed anyway, should be returned as well.} } \details{ Calculation of \eqn{e^A} and the Exponential Frechet-Derivative \eqn{L(A,E)}. When \code{method = "SPS"} (by default), the with the Scaling - Padé - Squaring Method is used, in an R-Implementation of Al-Mohy and Higham (2009)'s Algorithm 6.4. \describe{ \item{Step 1:}{Scaling (of A and E)} \item{Step 2:}{Padé-Approximation of \eqn{e^A} and \eqn{L(A,E)}} \item{Step 3:}{Squaring (reversing step 1)} } \code{method = "blockEnlarge"} uses the matrix identity of %% FIXME use nice LaTeX \deqn{f(\left{ .... \right} ) } \deqn{f([A E ; 0 A ]) = [f(A) Df(A); 0 f(A)]} for the \eqn{2n \times 2n}{(2n) x (2n)} block matrices where \eqn{f(A) := expm(A)} and \eqn{Df(A) := L(A,E)}. Note that \code{"blockEnlarge"} is much simpler to implement but slower (CPU time is doubled for \eqn{n = 100}). } \value{ a list with components \item{expm}{if \code{expm} is true, the matrix exponential (\eqn{n \times n}{n x n} matrix).} \item{Lexpm}{the Exponential-Frechet-Derivative \eqn{L(A,E)}, a matrix of the same dimension.} } \references{see \code{\link{expmCond}}.} \author{Michael Stadelmann (final polish by Martin Maechler).} \seealso{ \code{\link{expm.Higham08}} for the matrix exponential. \code{\link{expmCond}} for exponential condition number computations which are based on \code{expmFrechet}. } \examples{ (A <- cbind(1, 2:3, 5:8, c(9,1,5,3))) E <- matrix(1e-3, 4,4) (L.AE <- expmFrechet(A, E)) all.equal(L.AE, expmFrechet(A, E, "block"), tolerance = 1e-14) ## TRUE } \keyword{algebra} \keyword{math} expm/man/matStig.Rd0000644000176200001440000000277611406622454013715 0ustar liggesusers\name{matStig} \alias{matStig} \docType{data} \title{Stig's "infamous" Example Matrix} \description{ Stig Mortensen wrote on Oct 22, 2007 to the authors of the \pkg{Matrix} package with subject \dQuote{Strange result from expm}. There, he presented the following \eqn{8 \times 8}{8 * 8} matrix for which the Matrix \code{expm()} gave a \dQuote{strange} result. As we later researched, the result indeed was wrong: the correct entries were wrongly permuted. The reason has been in the underlying source code in Octave from which it had been ported to \pkg{Matrix}. } \usage{data(matStig)} \author{Martin Maechler} \examples{ data(matStig) as(matStig, "sparseMatrix") # since that prints more nicely. ## For more compact printing: op <- options(digits = 4) E1 <- expm(matStig, "Ward77", preconditioning="buggy") # the wrong result as(E1, "sparseMatrix") str(E2 <- expm(matStig, "Pade"))# the correct one (has "accuracy" attribute) as(E2, "sparseMatrix") attr(E2,"accuracy") <- NULL # don't want it below E3 <- expm(matStig, "R_Eigen") # even that is fine here all.equal(E1,E2) # not at all equal (rel.difference >~= 1.) stopifnot(all.equal(E3,E2)) # == ##________ The "proof" that "Ward77" is wrong _________ M <- matStig Et1 <- expm(t(M), "Ward77", precond= "buggy") Et2 <- expm(t(M), "Pade"); attr(Et2,"accuracy") <- NULL all.equal(Et1, t(E1)) # completely different (rel.diff ~ 1.7 (platform dep.)) stopifnot(all.equal(Et2, t(E2))) # the same (up to tolerance) options(op) } \keyword{array} \keyword{datasets} expm/man/logm.Rd0000644000176200001440000000626613777326364013257 0ustar liggesusers\name{logm} \alias{logm} \title{Matrix Logarithm} \description{ This function computes the (principal) matrix logarithm of a square matrix. A logarithm of a matrix \eqn{A} is \eqn{L} such that \eqn{A= e^L} (meaning \code{A == expm(L)}), see the documentation for the matrix exponential, \code{\link{expm}}, which can be defined as \deqn{e^L := \sum_{r=0}^\infty L^r/r! .}{sum[r = 0,..,Inf; L^r/r!] .} } \usage{ logm(x, method = c("Higham08", "Eigen"), % order = 8, trySym = TRUE, tol = .Machine$double.eps) } \arguments{ \item{x}{a square matrix.} \item{method}{a string specifying the algorithmic method to be used. The default uses the algorithm by Higham(2008). The simple \code{"Eigen"} method tries to diagonalise the matrix \code{x}; if that is not possible, it raises an error. } % \item{order}{only for \code{method = "Eigen"} .. FIXME} % \item{trySym}{only for \code{method = "Eigen"} .. FIXME} \item{tol}{a given tolerance used to check if \code{x} is computationally singular when \code{method = "Eigen"}.} } \details{ The exponential of a matrix is defined as the infinite Taylor series \deqn{e^M = \sum_{k = 1}^\infty \frac{M^k}{k!}.}{% exp(M) = I + M + M^2/2! + M^3/3! + \dots.} The matrix logarithm of \eqn{A} is a matrix \eqn{M} such that \eqn{exp(M) = A}. Note that there typically are an infinite number number of such matrices, and we compute the \emph{prinicipal} matrix logarithm, see the references. Method \code{"Higham08"} works via \dQuote{\emph{inverse} scaling and squaring}, and from the Schur decomposition, applying a matrix square root computation. It is somewhat slow but also works for non-diagonalizable matrices. } \references{ Higham, N.~J. (2008). \emph{Functions of Matrices: Theory and Computation}; Society for Industrial and Applied Mathematics, Philadelphia, PA, USA. The Matrix Logarithm is very nicely defined by Wikipedia, \url{https://en.wikipedia.org/wiki/Matrix_logarithm}. } \value{ A matrix \sQuote{as \code{x}} with the matrix logarithm of \code{x}, i.e., \code{all.equal( expm(logm(x)), x, tol)} is typically true for quite small tolerance \code{tol}. } \seealso{ \code{\link{expm}} } \author{ Method \code{"Higham08"} was implemented by Michael Stadelmann as part of his master thesis in mathematics, at ETH Zurich; the \code{"Eigen"} method by Christophe Dutang. } \examples{ m <- diag(2) logm(m) expm(logm(m)) ## Here, logm() is barely defined, and Higham08 has needed an amendment ## in order for not to loop forever: D0 <- diag(x=c(1, 0.)) (L. <- logm(D0)) stopifnot( all.equal(D0, expm(L.)) ) ## A matrix for which clearly no logm(.) exists: (m <- cbind(1:2, 1)) (l.m <- try(logm(m))) ## all NA {Warning in sqrt(S[ij, ij]) : NaNs produced} ## on r-patched-solaris-x86, additionally gives ## Error in solve.default(X[ii, ii] + X[ij, ij], S[ii, ij] - sumU) : ## system is computationally singular: reciprocal condition number = 0 ## Calls: logm ... logm.Higham08 -> rootS -> solve -> solve -> solve.default if(!inherits(l.m, "try-error")) stopifnot(is.na(l.m)) ## The "Eigen" method ``works'' but wrongly : expm(logm(m, "Eigen")) } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/sqrtm.Rd0000644000176200001440000000212711406665466013453 0ustar liggesusers\name{sqrtm} \alias{sqrtm} \title{Matrix Square Root} \description{ This function computes the matrix square root of a square matrix. The sqrt of a matrix \eqn{A} is \eqn{S} such that \eqn{A = S S}. } \usage{ sqrtm(x) } \arguments{ \item{x}{a square matrix.} } \details{ The matrix square root \eqn{S} of \eqn{M}, \eqn{S = sqrtm(M)} is defined as one (the \dQuote{principal}) \eqn{S} such that \eqn{S S = S^2 = M}, (in \R, \code{all.equal( S \%*\% S , M )}). The method works from the Schur decomposition. } \value{ A matrix \sQuote{as \code{x}} with the matrix sqrt of \code{x}. } \references{ Higham, N.~J. (2008). \emph{Functions of Matrices: Theory and Computation}; Society for Industrial and Applied Mathematics, Philadelphia, PA, USA. } \seealso{ \code{\link{expm}}, \code{\link{logm}} } \author{ Michael Stadelmann wrote the first version. } \examples{ m <- diag(2) sqrtm(m) == m # TRUE (m <- rbind(cbind(1, diag(1:3)),2)) sm <- sqrtm(m) sm zapsmall(sm \%*\% sm) # Zap entries ~= 2e-16 stopifnot(all.equal(m, sm \%*\% sm)) } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/expm.Rd0000644000176200001440000002373113777326364013266 0ustar liggesusers\name{expm} \alias{expm} \alias{mexp}% for now \title{Matrix Exponential} \description{ This function computes the exponential of a square matrix \eqn{A}, defined as the sum from \eqn{r=0} to infinity of \eqn{A^r/r!}. Several methods are provided. The Taylor series and Padé approximation are very importantly combined with scaling and squaring. } \usage{ expm(x, method = c("Higham08.b", "Higham08", "AlMohy-Hi09", "Ward77", "PadeRBS", "Pade", "Taylor", "PadeO", "TaylorO", "R_Eigen", "R_Pade", "R_Ward77", "hybrid_Eigen_Ward"), order = 8, trySym = TRUE, tol = .Machine$double.eps, do.sparseMsg = TRUE, preconditioning = c("2bal", "1bal", "buggy")) } \arguments{ \item{x}{a square matrix.} \item{method}{\code{"Higham08.b"}, \code{"Ward77"}, \code{"Pade"} or \code{"Taylor"}, etc; The default is now \code{"Higham08.b"} which uses Higham's 2008 algorithm with \emph{additional} balancing preconditioning, see \code{\link{expm.Higham08}}. The versions with "*O" call the original Fortran code, whereas the first ones call the BLAS-using and partly simplified newer code.\cr \code{"R_Pade"} uses an \R-code version of \code{"Pade"} for didactical reasons, and\cr \code{"R_Ward77"} uses an \R version of \code{"Ward77"}, still based on LAPACK's \code{dgebal}, see \R interface \code{\link{dgebal}}. This has enabled us to diagnose and fix the bug in the original octave implementation of \code{"Ward77"}. \code{"R_Eigen"} tries to diagonalise the matrix \code{x}, if not possible, \code{"R_Eigen"} raises an error. \code{"hybrid_Eigen_Ward"} method also tries to diagonalise the matrix \code{x}, if not possible, it uses \code{"Ward77"} algorithm. } \item{order}{an integer, the order of approximation to be used, for the "Pade" and "Taylor" methods. The best value for this depends on machine precision (and slightly on \code{x}) but for the current double precision arithmetic, one recommendation (and the Matlab implementations) uses \code{order = 6} unconditionally;\cr our default, \code{8}, is from Ward(1977, p.606)'s recommendation, but also used for \code{"AlMohy-Hi09"} where a high order \code{order=12} may be more appropriate (and slightly more expensive).} \item{trySym}{logical indicating if \code{method = "R_Eigen"} should use \code{\link{isSymmetric}(x)} and take advantage for (almost) symmetric matrices.} \item{tol}{a given tolerance used to check if \code{x} is computationally singular when \code{method = "hybrid_Eigen_Ward"}.} \item{do.sparseMsg}{logical allowing a message about sparse to dense coercion; setting it \code{FALSE} suppresses that message.} \item{preconditioning}{a string specifying which implementation of Ward(1977) should be used when \code{method = "Ward77"}. %%% FIXME explain more } } \details{ The exponential of a matrix is defined as the infinite Taylor series \deqn{e^M = \sum_{k = 1}^\infty \frac{M^k}{k!}.}{% exp(M) = I + M + M^2/2! + M^3/3! + \dots} For the "Pade" and "Taylor" methods, there is an \code{"accuracy"} attribute of the result. It is an upper bound for the L2 norm of the Cauchy error \code{expm(x, *, order + 10) - expm(x, *, order)}. Currently, only algorithms which are \emph{\dQuote{\R-code only}} accept \emph{sparse} matrices (see the \code{\link[Matrix:sparseMatrix-class]{sparseMatrix}} class in package \pkg{Matrix}), i.e., currently only \code{"R_Eigen"} and \code{"Higham08"}. } \value{ The matrix exponential of \code{x}. } \seealso{ The package vignette for details on the algorithms and calling the function from external packages. \code{\link{expm.Higham08}} for \code{"Higham08"}. \code{\link{expAtv}(A,v,t)} computes \eqn{e^{At} v} (for scalar \eqn{t} and \eqn{n}-vector \eqn{v}) \emph{directly} and more efficiently than computing \eqn{e^{At}}. } \author{ The \code{"Ward77"} method:\cr Vincent Goulet \email{vincent.goulet@act.ulaval.ca}, and Christophe Dutang, based on code translated by Doug Bates and Martin Maechler from the implementation of the corresponding Octave function contributed by A. Scottedward Hodel \email{A.S.Hodel@eng.auburn.edu}. The \code{"PadeRBS"} method:\cr Roger B. Sidje, see the EXPOKIT reference. The \code{"PadeO"} and \code{"TaylorO"} methods:\cr Marina Shapira (U Oxford, UK) and David Firth (U Warwick, UK); The \code{"Pade"} and \code{"Taylor"} methods are slight modifications of the "*O" ([O]riginal versions) methods, by Martin Maechler, using BLAS and LINPACK where possible. The \code{"hybrid_Eigen_Ward"} method by Christophe Dutang is a C translation of \code{"R_Eigen"} method by Martin Maechler. The \code{"Higham08"} and \code{"Higham08.b"} (current default) were written by Michael Stadelmann, see \code{\link{expm.Higham08}}. The \code{"AlMohy-Hi09"} implementation (\R code interfacing to stand-alone C) was provided and donated by Drew Schmidt, U. Tennesse. } \references{ Ward, R. C. (1977). Numerical computation of the matrix exponential with accuracy estimate. \emph{SIAM J. Num. Anal.} \bold{14}, 600--610. Roger B. Sidje (1998). EXPOKIT: Software package for computing matrix exponentials. ACM - Transactions on Mathematical Software \bold{24}(1), 130--156. Moler, C and van Loan, C (2003). Nineteen dubious ways to compute the exponential of a matrix, twenty-five years later. \emph{SIAM Review} \bold{45}, 3--49. At \doi{10.1137/S00361445024180} Awad H. Al-Mohy and Nicholas J. Higham (2009) A New Scaling and Squaring Algorithm for the Matrix Exponential. \emph{SIAM. J. Matrix Anal. & Appl.}, \bold{31}(3), 970--989. } \note{ For a good general discussion of the matrix exponential problem, see Moler and van Loan (2003). } \examples{ x <- matrix(c(-49, -64, 24, 31), 2, 2) expm(x) expm(x, method = "AlMohy-Hi09") ## ---------------------------- ## Test case 1 from Ward (1977) ## ---------------------------- test1 <- t(matrix(c( 4, 2, 0, 1, 4, 1, 1, 1, 4), 3, 3)) expm(test1, method="Pade") ## Results on Power Mac G3 under Mac OS 10.2.8 ## [,1] [,2] [,3] ## [1,] 147.86662244637000 183.76513864636857 71.79703239999643 ## [2,] 127.78108552318250 183.76513864636877 91.88256932318409 ## [3,] 127.78108552318204 163.67960172318047 111.96810624637124 ## -- these agree with ward (1977, p608) ## Compare with the naive "R_Eigen" method: try( expm(test1, method="R_Eigen") ) ## platform depently, sometimes gives an error from solve ## or is accurate or one older result was ## [,1] [,2] [,3] ##[1,] 147.86662244637003 88.500223574029647 103.39983337000028 ##[2,] 127.78108552318220 117.345806155250600 90.70416537273444 ##[3,] 127.78108552318226 90.384173332156763 117.66579819582827 ## -- hopelessly inaccurate in all but the first column. ## ## ---------------------------- ## Test case 2 from Ward (1977) ## ---------------------------- test2 <- t(matrix(c( 29.87942128909879, .7815750847907159, -2.289519314033932, .7815750847907159, 25.72656945571064, 8.680737820540137, -2.289519314033932, 8.680737820540137, 34.39400925519054), 3, 3)) expm(test2, method="Pade") ## [,1] [,2] [,3] ##[1,] 5496313853692357 -18231880972009844 -30475770808580828 ##[2,] -18231880972009852 60605228702227024 101291842930256144 ##[3,] -30475770808580840 101291842930256144 169294411240859072 ## -- which agrees with Ward (1977) to 13 significant figures expm(test2, method="R_Eigen") ## [,1] [,2] [,3] ##[1,] 5496313853692405 -18231880972009100 -30475770808580196 ##[2,] -18231880972009160 60605228702221760 101291842930249376 ##[3,] -30475770808580244 101291842930249200 169294411240850880 ## -- in this case a very similar degree of accuracy. ## ## ---------------------------- ## Test case 3 from Ward (1977) ## ---------------------------- test3 <- t(matrix(c( -131, 19, 18, -390, 56, 54, -387, 57, 52), 3, 3)) expm(test3, method="Pade") ## [,1] [,2] [,3] ##[1,] -1.5096441587713636 0.36787943910439874 0.13533528117301735 ##[2,] -5.6325707997970271 1.47151775847745725 0.40600584351567010 ##[3,] -4.9349383260294299 1.10363831731417195 0.54134112675653534 ## -- agrees to 10dp with Ward (1977), p608. expm(test3, method="R_Eigen") ## [,1] [,2] [,3] ##[1,] -1.509644158796182 0.3678794391103086 0.13533528117547022 ##[2,] -5.632570799902948 1.4715177585023838 0.40600584352641989 ##[3,] -4.934938326098410 1.1036383173309319 0.54134112676302582 ## -- in this case, a similar level of agreement with Ward (1977). ## ## ---------------------------- ## Test case 4 from Ward (1977) ## ---------------------------- test4 <- structure(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 1e-10, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0), .Dim = c(10, 10)) attributes(expm(test4, method="Pade")) max(abs(expm(test4, method="Pade") - expm(test4, method="R_Eigen"))) ##[1] 8.746826694186494e-08 ## -- here mexp2 is accurate only to 7 d.p., whereas mexp ## is correct to at least 14 d.p. ## ## Note that these results are achieved with the default ## settings order=8, method="Pade" -- accuracy could ## presumably be improved still further by some tuning ## of these settings. ## ## example of computationally singular matrix ## m <- matrix(c(0,1,0,0), 2,2) try( expm(m, m="R_Eigen") ) ## error since m is computationally singular expm(m, m="hybrid") ## hybrid use the Ward77 method } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/expmCond.Rd0000644000176200001440000000631614531337476014065 0ustar liggesusers\name{expmCond} \title{Exponential Condition Number of a Matrix} \Rdversion{1.1} \alias{expmCond} \description{ Compute the exponential condition number of a matrix, either with approximation methods, or exactly and very slowly. } \usage{ expmCond(A, method = c("1.est", "F.est", "exact"), expm = TRUE, abstol = 0.1, reltol = 1e-6, give.exact = c("both", "1.norm", "F.norm")) } \arguments{ \item{A}{a square matrix} \item{method}{a string; either compute 1-norm or F-norm \emph{approximations}, or compte these \emph{exactly}.} \item{expm}{logical indicating if the matrix exponential itself, which is computed anyway, should be returned as well.} \item{abstol, reltol}{for \code{method = "F.est"}, numerical \eqn{\ge 0}{>= 0}, as \emph{absolute} and \emph{relative} error tolerance.} \item{give.exact}{for \code{method = "exact"}, specify if only the 1-norm, the Frobenius norm, or both are to be computed.} } \details{ \code{method = "exact"}, aka Kronecker-Sylvester algorithm, computes a Kronecker matrix of dimension \eqn{n^2 \times n^2}{n^2 x n^2} and hence, with \eqn{O(n^5)} complexity, is prohibitely slow for non-small \eqn{n}. It computes the \emph{exact} exponential-condition numbers for both the Frobenius and/or the 1-norm, depending on \code{give.exact}. The two other methods compute approximations, to these norms, i.e., \bold{est}imate them, using algorithms from Higham, chapt.~3.4, both with complexity \eqn{O(n^3)}. %% FIXME: Say more } \value{ when \code{expm = TRUE}, for \code{method = "exact"}, a \code{\link{list}} with components \item{expm}{containing the matrix exponential, \code{\link{expm.Higham08}(A)}.} \item{expmCond(F|1)}{numeric scalar, (an approximation to) the (matrix exponential) condition number, for either the 1-norm (\code{expmCond1}) or the Frobenius-norm (\code{expmCondF}).} When \code{expm} is false and \code{method} one of the approximations (\code{"*.est"}), the condition number is returned directly (i.e., \code{\link{numeric}} of length one). } \references{ Awad H. Al-Mohy and Nicholas J. Higham (2009). \emph{Computing Fréchet Derivative of the Matrix Exponential, with an application to Condition Number Estimation}; MIMS EPrint 2008.26; Manchester Institute for Mathematical Sciences, U. Manchester, UK. \url{https://eprints.maths.manchester.ac.uk/1218/01/covered/MIMS_ep2008_26.pdf} Higham, N.~J. (2008). \emph{Functions of Matrices: Theory and Computation}; Society for Industrial and Applied Mathematics, Philadelphia, PA, USA. Michael Stadelmann (2009) \emph{Matrixfunktionen} ... Master's thesis; see reference in \code{\link{expm.Higham08}}. } \author{ Michael Stadelmann (final polish by Martin Maechler). } \seealso{ \code{\link{expm.Higham08}} for the matrix exponential. } \examples{ set.seed(101) (A <- matrix(round(rnorm(3^2),1), 3,3)) eA <- expm.Higham08(A) stopifnot(all.equal(eA, expm::expm(A), tolerance= 1e-15)) C1 <- expmCond(A, "exact") C2 <- expmCond(A, "1.est") C3 <- expmCond(A, "F.est") all.equal(C1$expmCond1, C2$expmCond, tolerance= 1e-15)# TRUE all.equal(C1$expmCondF, C3$expmCond)# relative difference of 0.001... } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/balance.Rd0000644000176200001440000000623614547727173013702 0ustar liggesusers\name{balance} \alias{balance} \alias{dgebal} \title{Balance a Square Matrix via LAPACK's DGEBAL} \description{ Balance a square matrix via LAPACK's \code{DGEBAL}. This is an \R interface, mainly used for experimentation. This LAPACK routine is used internally for Eigenvalue decompositions, but also, in Ward(1977)'s algorithm for the matrix exponential. The name \code{balance()} is preferred nowadays, and \dQuote{dgebal()} has been deprecated (finally, after 9 years ...). } \usage{ balance(A, job = c("B", "N", "P", "S")) ## Deprecated now: ## dgebal(A, job = c("B", "N", "P", "S")) } \arguments{ \item{A}{a square (\eqn{n\times n}{n x n}) numeric matrix.} \item{job}{a one-letter string specifying the \sQuote{job} for DGEBAL. \describe{ \item{P}{\bold{P}ermutation} \item{S}{\bold{S}caling} \item{B}{\bold{B}oth permutation and scaling} \item{N}{\bold{N}one} } } } \value{ A list with components \item{z}{the transformation of matrix \code{A}, after permutation and or scaling.} \item{scale}{numeric vector of length \eqn{n}, containing the permutation and/or scale vectors applied.} \item{i1,i2}{integers (length 1) in \eqn{\{1,2,\dots,n\}}, denoted by \code{ILO} and \code{IHI} respectively in the LAPACK documentation. Only relevant for \code{"P"} or \code{"B"}, they describe where permutations and where scaling took place; see the Details section. } } \details{ An excerpt of the LAPACK documentation about DGEBAL(), describing the result \describe{ \item{i1 ("ILO")}{(output) integer} \item{i2 ("IHI")}{(output) integer\cr \code{i1} and \code{i2} are set to integers such that on exit \code{z[i,j] = 0} if \eqn{i > j} and \eqn{j = 1,...,i1-1} or \eqn{i = i2+1,...,n}. If \code{job = 'N'} or \code{'S'}, \code{i1 = 1} and \code{i2 = n}.} \item{scale}{(output) numeric vector of length \code{n}. Details of the permutations and scaling factors applied to \code{A}. If \code{P[j]} is the index of the row and column interchanged with row and column \code{j} and \code{D[j]} is the scaling factor applied to row and column j, then \code{scale[j] = P[j]} for \eqn{j = 1,...,i1-1}\cr \code{ = D[j]} for \eqn{j = i1,...,i2},\cr \code{ = P[j]} for \eqn{j = i2+1,...,n}. The order in which the interchanges are made is \code{n} to \code{i2+1}, then \code{1} to \code{i1-1}.} } Look at the LAPACK documentation for more details. } \references{ LAPACK Reference Manual } \author{Martin Maechler} \seealso{\code{\link{eigen}}, \code{\link{expm}}. } \examples{ m4 <- rbind(c(-1,-1, 0, 0), c( 0, 0,10,10), c( 0, 0,10, 0), c( 0,10, 0, 0)) (b4 <- balance(m4)) ## --- for testing and didactical reasons : ---- if(expm:::doExtras()) withAutoprint({ sessionInfo() packageDescription("Matrix") "expm installed at" dirname(attr(packageDescription("expm"), "file")) }) demo(balanceTst) # also defines the balanceTst() function # which in its tests ``defines'' what # the return value means, notably (i1,i2,scale) } \keyword{array} \keyword{arith} expm/man/expAtv.Rd0000644000176200001440000000567212407501461013546 0ustar liggesusers\name{expAtv} \title{Compute Matrix Exponential exp(A t) * v directly} \alias{expAtv} \alias{expmv}% - the MATLAB name "mv" = Matrix-Vector (in Stats/R mv:= multivariate) \description{ Compute \eqn{\exp(A t) * v} directly, without evaluating \eqn{\exp(A)}. } \usage{ expAtv(A, v, t = 1, method = "Sidje98", rescaleBelow = 1e-6, tol = 1e-07, btol = 1e-07, m.max = 30, mxrej = 10, verbose = getOption("verbose")) } \arguments{ \item{A}{n x n matrix} \item{v}{n - vector} \item{t}{number (scalar);}% ___ FIXME allow vector ? ___} \item{method}{a string indicating the method to be used; there's only one currently; we would like to add newer ones.} \item{rescaleBelow}{if \code{\link{norm}(A,"I")} is smaller than \code{rescaleBelow}, rescale \code{A} to norm 1 and \code{t} such that \eqn{A t} remains unchanged. This step is in addition to Sidje's original algorithm and easily seen to be necessary even in simple cases (e.g., \eqn{n = 3}).} \item{tol, btol}{tolerances; these are tuning constants of the "Sidje1998" method which the user should typically \emph{not} change.} \item{m.max, mxrej}{integer constants you should only change if you know what you're doing} \item{verbose}{flag indicating if the algorithm should be verbose..} } \value{a list with components \item{eAtv}{.....fixme...} } % \details{ % } \references{ Roger B. Sidje (1998) EXPOKIT: Software Package for Computing Matrix Exponentials. \emph{ACM - Transactions On Mathematical Software} \bold{24}(1), 130--156. ((NOT yet available!))\cr%% i.e., in expm package, but see ../Misc/README and ../Misc/expmv/ Al-Mohy, A. and Higham, N. (2011). Computing the Action of the Matrix Exponential, with an Application to Exponential Integrators. \emph{SIAM Journal on Scientific Computing}, \bold{33}(2), 488--511. %% @article{doi:10.1137/100788860, %% author = {Al-Mohy, A. and Higham, N.}, %% title = {Computing the Action of the Matrix Exponential, with an %% Application to Exponential Integrators}, %% journal = {SIAM Journal on Scientific Computing}, %% volume = 33, %% number = 2, %% pages = {488-511}, %% year = 2011, %% doi = {10.1137/100788860}, %% URL = {http://epubs.siam.org/doi/abs/10.1137/100788860}, %% } } \author{Ravi Varadhan, Johns Hopkins University; Martin Maechler (cosmetic, generalization to sparse matrices; rescaling (see \code{rescaleBelow}). } % \note{ % } \seealso{ \code{\link{expm}}%,.... } \examples{%% tests are at end of ../tests/ex2.R source(system.file("demo", "exact-fn.R", package = "expm")) ##-> rnilMat() ; xct10 set.seed(1) (s5 <- Matrix(m5 <- rnilMat(5))); v <- c(1,6:9) (em5 <- expm(m5)) r5 <- expAtv(m5, v) r5. <- expAtv(s5, v) stopifnot(all.equal(r5, r5., tolerance = 1e-14), all.equal(c(em5 \%*\% v), r5$eAtv)) v <- 10:1 with(xct10, all.equal(expm(m), expm)) all.equal(c(xct10$expm \%*\% v), expAtv(xct10$m, v)$eAtv) } \keyword{algebra} \keyword{math} expm/man/expm.Higham08.Rd0000644000176200001440000001145114512207445014610 0ustar liggesusers\name{expm.Higham08} \Rdversion{1.1} \alias{expm.Higham08} \title{Matrix Exponential [Higham 2008]} \description{ Calculation of matrix exponential \eqn{e^A} with the \sQuote{Scaling & Squaring} method with balancing. Implementation of Higham's Algorithm from his book (see references), Chapter 10, Algorithm 10.20. The balancing option is an extra from Michael Stadelmann's Masters thesis. } \usage{ expm.Higham08(A, balancing = TRUE) } \arguments{ \item{A}{square matrix, may be a \code{"\linkS4class{sparseMatrix}"}, currently only if \code{balancing} is false.} \item{balancing}{logical indicating if balancing should happen (before and after scaling and squaring).} } \details{ The algorithm comprises the following steps \describe{ \item{0.}{Balancing} \item{1.}{Scaling} \item{2.}{Padé-Approximation} \item{3.}{Squaring} \item{4.}{Reverse Balancing} } } \value{ a matrix of the same dimension as \code{A}, the matrix exponential of \code{A}. } \references{ Higham, Nicholas J. (2008). \emph{Functions of Matrices: Theory and Computation}; SIAM (Society for Industrial and Applied Mathematics), Philadelphia, USA; \doi{10.1137/1.9780898717778} Michael Stadelmann (2009). \emph{Matrixfunktionen; Analyse und Implementierung}. [in German] Master's thesis and Research Report 2009-12, SAM, ETH Zurich; \url{https://math.ethz.ch/sam/research/reports.html?year=2009}, or the pdf directly at \url{https://www.sam.math.ethz.ch/sam_reports/reports_final/reports2009/2009-12.pdf}. } \author{ Michael Stadelmann (final polish by Martin Maechler). } \note{ \code{expm.Higham8()} no longer needs to be called directly; rather \code{expm(A, "Higham8b")} and \code{expm(A, "Higham8")} correspond to the two options of \code{balancing = TRUE || FALSE}. } \seealso{ The other algorithms \code{\link{expm}(x, method = *)}. \code{\link{expmCond}}, to compute the exponential-\emph{condition} number. } \examples{ ## The *same* examples as in ../expm.Rd {FIXME} -- x <- matrix(c(-49, -64, 24, 31), 2, 2) expm.Higham08(x) ## ---------------------------- ## Test case 1 from Ward (1977) ## ---------------------------- test1 <- t(matrix(c( 4, 2, 0, 1, 4, 1, 1, 1, 4), 3, 3)) expm.Higham08(test1) ## [,1] [,2] [,3] ## [1,] 147.86662244637000 183.76513864636857 71.79703239999643 ## [2,] 127.78108552318250 183.76513864636877 91.88256932318409 ## [3,] 127.78108552318204 163.67960172318047 111.96810624637124 ## -- these agree with ward (1977, p608) ## ---------------------------- ## Test case 2 from Ward (1977) ## ---------------------------- test2 <- t(matrix(c( 29.87942128909879, .7815750847907159, -2.289519314033932, .7815750847907159, 25.72656945571064, 8.680737820540137, -2.289519314033932, 8.680737820540137, 34.39400925519054), 3, 3)) expm.Higham08(test2) expm.Higham08(test2, balancing = FALSE) ## [,1] [,2] [,3] ##[1,] 5496313853692405 -18231880972009100 -30475770808580196 ##[2,] -18231880972009160 60605228702221760 101291842930249376 ##[3,] -30475770808580244 101291842930249200 169294411240850880 ## -- in this case a very similar degree of accuracy. ## ---------------------------- ## Test case 3 from Ward (1977) ## ---------------------------- test3 <- t(matrix(c( -131, 19, 18, -390, 56, 54, -387, 57, 52), 3, 3)) expm.Higham08(test3) expm.Higham08(test3, balancing = FALSE) ## [,1] [,2] [,3] ##[1,] -1.5096441587713636 0.36787943910439874 0.13533528117301735 ##[2,] -5.6325707997970271 1.47151775847745725 0.40600584351567010 ##[3,] -4.9349383260294299 1.10363831731417195 0.54134112675653534 ## -- agrees to 10dp with Ward (1977), p608. ??? (FIXME) ## ---------------------------- ## Test case 4 from Ward (1977) ## ---------------------------- test4 <- structure(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 1e-10, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0), .Dim = c(10, 10)) E4 <- expm.Higham08(test4) Matrix(zapsmall(E4)) S4 <- as(test4, "sparseMatrix") # some R based expm() methods work for sparse: ES4 <- expm.Higham08(S4, bal=FALSE) stopifnot(all.equal(E4, unname(as.matrix(ES4)))) ## NOTE: Need much larger sparse matrices for sparse arith to be faster! ## ## example of computationally singular matrix ## m <- matrix(c(0,1,0,0), 2,2) eS <- expm.Higham08(m) # "works" (hmm ...) } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/matpow.Rd0000644000176200001440000000207712016223562013601 0ustar liggesusers\name{matpow} \alias{\%^\%} \alias{matpow} \title{Matrix Power} \description{ Compute the \eqn{k}-th power of a matrix. Whereas \code{x^k} computes \emph{element wise} powers, \code{x \%^\% k} corresponds to \eqn{k - 1} matrix multiplications, \code{x \%*\% x \%*\% ... \%*\% x}. } \usage{ x \%^\% k } \arguments{ \item{x}{a square \code{\link{matrix}}.} \item{k}{an integer, \eqn{k \ge 0}{k >= 0}.} } \details{ Argument \eqn{k} is coerced to integer using \code{\link{as.integer}}. The algorithm uses \eqn{O(log_2(k))}{O(log2(k))} matrix multiplications. } \value{ A matrix of the same dimension as \code{x}. } \author{ Based on an R-help posting of Vicente Canto Casasola, and Vincent Goulet's C implementation in \pkg{actuar}. } \note{ If you think you need \code{x^k} for \eqn{k < 0}, then consider instead \code{solve(x \%^\% (-k))}. } \seealso{ \code{\link{\%*\%}} for matrix multiplication. } \examples{ A <- cbind(1, 2 * diag(3)[,-1]) A A \%^\% 2 stopifnot(identical(A, A \%^\% 1), A \%^\% 2 == A \%*\% A) } \keyword{array} \keyword{arith} expm/TODO0000644000176200001440000000111113044611522011703 0ustar liggesusers#-*-org-*- * TODO expm() should work for sparse matrices for more methods * expAtv(A, v, t) ** TODO should work for *vector* t ** TODO should implement the new method by Al-Mohy and Higham (2011), see file:Misc/README and file:Misc/expmv/ * TODO Implement Higham (2009) {we have 2008} : see file:inst/doc/expm.bib * TODO dgebal() -- now renamed to balance() == Matlab name, *but* add the functionality (available in Matlab) to also return the transforming diagonal matrix D --> file:R/balance.R * TODO Rmpfr version possible (s.Pade.s), as soon as solve() for Rmpfr expm/DESCRIPTION0000644000176200001440000000364014547745062012752 0ustar liggesusersPackage: expm Type: Package Title: Matrix Exponential, Log, 'etc' Version: 0.999-9 Date: 2024-01-11 Authors@R: c(person("Martin", "Maechler", role=c("aut","cre"), email="maechler@stat.math.ethz.ch", comment = c(ORCID = "0000-0002-8685-9910")) , person("Christophe","Dutang", role = "aut", comment = c(ORCID = "0000-0001-6732-1501")) , person("Vincent", "Goulet", role = "aut", comment = c(ORCID = "0000-0002-9315-5719")) , person("Douglas", "Bates", role = "ctb", comment = "cosmetic clean up, in svn r42") , person("David", "Firth", role = "ctb", comment = "expm(method= \"PadeO\" and \"TaylorO\")") , person("Marina", "Shapira", role = "ctb", comment = "expm(method= \"PadeO\" and \"TaylorO\")") , person("Michael", "Stadelmann", role = "ctb", comment = "\"Higham08*\" methods, see ?expm.Higham08...") ) Contact: expm-developers@lists.R-forge.R-project.org Description: Computation of the matrix exponential, logarithm, sqrt, and related quantities, using traditional and modern methods. Depends: Matrix Imports: methods Suggests: RColorBrewer, sfsmisc, Rmpfr BuildResaveData: no License: GPL (>= 2) URL: https://R-Forge.R-project.org/projects/expm/ BugReports: https://R-forge.R-project.org/tracker/?atid=472&group_id=107 Encoding: UTF-8 NeedsCompilation: yes Packaged: 2024-01-11 09:19:42 UTC; maechler Author: Martin Maechler [aut, cre] (), Christophe Dutang [aut] (), Vincent Goulet [aut] (), Douglas Bates [ctb] (cosmetic clean up, in svn r42), David Firth [ctb] (expm(method= "PadeO" and "TaylorO")), Marina Shapira [ctb] (expm(method= "PadeO" and "TaylorO")), Michael Stadelmann [ctb] ("Higham08*" methods, see ?expm.Higham08...) Maintainer: Martin Maechler Repository: CRAN Date/Publication: 2024-01-11 11:00:02 UTC expm/build/0000755000176200001440000000000014547731256012340 5ustar liggesusersexpm/build/vignette.rds0000644000176200001440000000031414547731256014675 0ustar liggesusersb```b`afb`b2 1# 'H( +G -KW*d)$&g'c]&1h0X" ,LHXs1dwI-HK î?+S+`zP԰Aհe ,s\ܠL t7`~΢r=xA$Gs=ʕXVr7N(lfexpm/build/partial.rdb0000644000176200001440000000007514547731241014461 0ustar liggesusersb```b`afb`b1 H020piּb C"%!7expm/tests/0000755000176200001440000000000014547731235012400 5ustar liggesusersexpm/tests/expm-Cond.R0000644000176200001440000000216112311702321014332 0ustar liggesusers#### Testing the Exponential Condition Number computations library(expm) mSource <- function(file, ...) source(system.file(file, ..., package = "expm", mustWork=TRUE), keep.source = FALSE) mSource("test-tools.R")## -> assertError(), rMat() ## getting examples where we know expm(.) "exactly": mSource("demo", "exact-fn.R") M <- xct10$m eC <- list(expmCondF = 566.582631819923, expmCond1 = 137.455837652872) C1 <- expmCond(M, "exact") (C2 <- expmCond(M, "1.est", expm=FALSE)) (C3. <- expmCond(M, "F.est", abstol = 0.1)[[1]]) (C3.1 <- expmCond(M, "F.est", abstol = 0.01, reltol = 1e-12)[[1]]) stopifnot(all.equal(C1[1:2], eC, tolerance = 1e-14), all.equal(C2 , eC$expmCond1, tolerance = 1e-14), all.equal(C3. , eC$expmCondF, tolerance = 1e-14, check.attributes = FALSE), all.equal(C3.1, eC$expmCondF, tolerance = 1e-14, check.attributes = FALSE)) cat('Time elapsed: ', (p1 <- proc.time()),'\n') # for ``statistical reasons'' ## cat('Time elapsed: ',(p2 <- proc.time())-p1,'\n') # for ``statistical reasons'' ## cat('Time elapsed: ',(p3 <- proc.time())-p2,'\n') # for ``statistical reasons'' expm/tests/exact-ex.R0000644000176200001440000003072414531337476014251 0ustar liggesusers#### Examples where we know the result "exactly" library(expm) options(digits = 4, width = 90, keep.source = FALSE) mSource <- function(file, ...) source(system.file(file, ..., package = "expm", mustWork=TRUE)) mSource("test-tools.R")## -> assertError(), rMat(), .. doExtras mSource("demo", "exact-fn.R") doExtras re.nilA3 <- function(xyz, EXPMlist) { stopifnot(is.list(EXPMlist)) r <- do.call(nilA3, as.list(xyz)) sapply(EXPMlist, function(Efn) relErr(r$expA, Efn(r$A))) } re.facMat <- function(n, EXPMlist, rFUN = rnorm, ...) { stopifnot(is.list(EXPMlist)) r <- facMat(n, rFUN, ...) vapply(EXPMlist, function(EXPM) { ct <- system.time(E <- EXPM(r$A), gc = FALSE)[[1]] c(relErr = relErr(r$expA, E), c.time = ct) }, double(2)) } re.m2ex3 <- function(eps, EXPMlist) { stopifnot(is.list(EXPMlist)) r <- m2ex3(eps) sapply(EXPMlist, function(EXPM) relErr(r$expA, EXPM(r$A))) } ## check 1x1 matrices stopifnot( ## these had failed before 2017-03-28 (= Liselotte's 58-th birthday): all.equal(as.matrix(sqrtm(matrix(4))), matrix(2)) , all.equal(as.matrix(logm (matrix(pi))), matrix(log(pi))) , ## these had "always" worked : all.equal(as.matrix(expm (matrix(0))), matrix(1)) , all.equal(as.matrix(expm (matrix(1))), matrix(exp(1))) ) set.seed(321) re <- replicate(1000, c(re.nilA3(rlnorm(3),list(function(x)expm(x,"Pade"))), re.nilA3(rnorm(3), list(function(x)expm(x,"Pade"))))) summary(t(re)) stopifnot(rowMeans(re) < 1e-15, apply(re, 1, quantile, 0.80) < 1e-16, apply(re, 1, quantile, 0.90) < 2e-15, apply(re, 1, max) < c(4e-14, 6e-15)) showProc.time() ## Check *many* random nilpotent 3 x 3 matrices: set.seed(321) RE <- replicate(1000, c(re.nilA3(rlnorm(3), list(function(x) expm(x, "Ward77"))), re.nilA3(rnorm(3), list(function(x) expm(x, "Ward77"))))) stopifnot(rowMeans(RE) < 1e-15, apply(RE, 1, quantile, 0.80) < 1e-16, apply(RE, 1, quantile, 0.90) < 2e-15, apply(RE, 1, max) < c(4e-14, 6e-15)) print(summary(t(RE))) epsC <- .Machine$double.eps cat("relErr(expm(.,Pade)) - relErr(expm(.,Ward77)) in Machine_eps units:\n") print(summary(c(re - RE)) / epsC) ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## -0.6183442 0.0000000 0.0000000 1.3650410 0.1399719 94.9809161 ## nb-mm3; ditto lynne (both x64), 2014-09-11: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## -0.8422 0.0000 0.0000 0.0725 0.1067 1.2205 ## 32-bit [i686, florence, Linx 3.14.8-100.fc19..]: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## -0.62 0.00 0.00 1.36 0.14 95.93 showProc.time() ###--- A second group --- where we know the diagonalization of A --- if(!require("Matrix")) q('no') ## ------ the rest really uses 'Matrix' ##---> now use expm::expm() since Matrix has its own may mask the expm one ## ^^^^^^^^^^^^ if(!dev.interactive(orNone=TRUE)) pdf("expm_exact-ex.pdf") ## rMat() relies on Matrix::rcond(): ## Now with the change default rcondMin, this "works" R40 <- rMat(40) R80 <- rMat(80) showProc.time() expm.safe.Eigen <- function(x, silent = FALSE) { r <- try(expm::expm(x, "R_Eigen"), silent = silent) if(inherits(r, "try-error")) NA else r } ## the S4 generic Matrix::expm ## the dgeMatrix method - adapted to Matrix changes, had *more versatile* ..2dge() : expm.Matr.dge <- function(x) getDataPart(getMethod("expm", "dgeMatrix"))(Matrix::.m2dense(x)) expmList <- list(Matr = Matrix::expm, Matr.d = expm.Matr.dge, Ward = function(x) expm::expm(x, "Ward77"), s.P.s = function(x) expm::expm(x, "Pade"), s.P.sO= function(x) expm::expm(x, "PadeO"), s.P.sRBS= function(x) expm::expm(x, "PadeRBS"), sPs.H08.= function(x) expm:: expm.Higham08(x, balancing=FALSE), sPs.H08b= function(x) expm:: expm.Higham08(x, balancing= TRUE), AmHi09.06= function(x) expm:::expm.AlMoHi09(x, p = 6), AmHi09.08= function(x) expm:::expm.AlMoHi09(x, p = 8), AmHi09.10= function(x) expm:::expm.AlMoHi09(x, p = 10), AmHi09.12= function(x) expm:::expm.AlMoHi09(x, p = 12), AmHi09.13= function(x) expm:::expm.AlMoHi09(x, p = 13), s.T.s = function(x) expm::expm(x, "Taylor"), s.T.sO= function(x) expm::expm(x, "TaylorO"), Eigen = expm.safe.Eigen, hybrid= function(x) expm::expm(x, "hybrid") ) set.seed(12) fRE <- replicate(if(doExtras) 100 else 20, re.facMat(20, expmList)) cat("Number of correct decimal digits for facMat(20, rnorm):\n") summary(-log10(t(fRE["relErr",,]))) ## Now look at that: boxplot(t(fRE["relErr",,]), log="y", notch=TRUE, ylim = c(8e-16, 1e-8), main = "relative errors for 'random' eigen-ok 20 x 20 matrix") showProc.time() if(doExtras) { str(rf100 <- replicate(20, re.facMat(100, expmList))) print(1000*t(apply(rf100["c.time",,], 1, summary))) ## lynne {Linux 2.6.34.7-56.fc13.x86_64 --- AMD Phenom II X4 925}: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## Ward 23 24 24.5 24.4 25.0 25 ## s.P.s 107 109 109.0 109.0 109.0 112 ## s.P.sO 188 190 191.0 192.0 193.0 198 ## s.P.sRBS 17 18 19.0 18.9 19.2 21 ## sPs.H08. 15 17 18.0 17.6 18.0 19 ## sPs.H08b 18 18 19.0 23.4 20.0 107 ## s.T.s 44 45 45.0 45.6 46.0 48 ## s.T.sO 96 98 99.0 100.0 100.0 116 ## Eigen 18 19 20.0 24.4 21.0 109 ## hybrid 40 42 42.0 47.1 44.0 133 ##--> take out the real slow ones for the subsequent tests: `%w/o%` <- function(x, y) x[!x %in% y] #-- x without y print(nms.swift <- names(expmList) %w/o% c("s.P.s", "s.P.sO", "s.T.s", "s.T.sO")) expmL.swift <- expmList[nms.swift] set.seed(18) ## 12 replicates is too small .. but then it's too slow otherwise: rf400 <- replicate(12, re.facMat(400, expmL.swift)) print(1000*t(apply(rf400["c.time",,], 1, summary))) ## lynne: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## Ward 1740 1790 1830 1820 1860 1900 ## s.P.sRBS 1350 1420 1440 1430 1450 1460 ## sPs.H08. 1020 1030 1130 1140 1210 1290 ## sPs.H08b 1120 1130 1220 1220 1300 1390 ## Eigen 962 977 989 992 1000 1030 ## hybrid 2740 2800 2840 2840 2890 2910 showProc.time() }## if(doExtras) only ## Now try an example with badly conditioned "random" M matrix... ## ... ## ... (not yet) ### m2ex3() --- The 2x2 example with bad condition , see A3 in ./ex2.R RE <- re.m2ex3(1e-8, expmList) sort(RE)# Ward + both sps.H08 are best; s.P.s fair, Eigen (and hybrid): ~1e-9 eps <- 10^-(1:18) t.m2 <- t(sapply(eps, re.m2ex3, EXPMlist = expmList)) ## --> 3 error messages from solve(V), 5 error messages from try(. "R_Eigen" ...) showProc.time() cbind(sort(apply(log(t.m2),2, median, na.rm=TRUE))) ## 'na.rm=TRUE' needed for Eigen which blows up for the last 3 eps t.m2.ranks <- sort(rowMeans(apply(t.m2, 1, rank))) cbind(signif(t.m2.ranks, 3)) ## lynne (x86_64, Linux 3.14.4-100; Intel i7-4765T), 2014-09: ## sPs.H08. 2.67 ## sPs.H08b 2.67 ## s.P.sRBS 3.06 ## Ward 4.03 ## AmHi09.13 4.33 <<- still not close to H08 ! ## AmHi09.12 5.86 ## s.T.s 8.33 ## s.T.sO 8.33 ## s.P.s 9.11 ## s.P.sO 9.11 ## hybrid 10.80 ## AmHi09.10 11.70 << astonishingly bad ## Eigen 12.60 ## AmHi09.08 13.10 ## AmHi09.06 14.40 print(t.m2[, names(t.m2.ranks)[1:8]], digits = 3) ## ==> 1st class: H08 (both) and (but slightly better than) Ward ## 2nd class s.T.s and s.P.s ## "bad" : hybrid and Eigen ## ??? AmHi09 - methods, up to order = 10 are worse ! if(require(RColorBrewer)) { ## Bcol <- brewer.pal(ncol(t.m2),"Dark2") Bcol <- brewer.pal(min(9, ncol(t.m2)), "Set1") Bcol <- Bcol[sqrt(colSums(col2rgb(Bcol)^2)) < 340] ## FIXME: more colors ==> ~/R/MM/GRAPHICS/color-palettes.R } else { ## 7 from Dark2 ## Bcol <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A", ## "#66A61E", "#E6AB02", "#A6761D") ## Rather: those from "Set1" Bcol <- c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00", # too bright: "#FFFF33", "#A65628", "#F781BF", "#999999") } matplot(eps, t.m2, type = "b", log = "xy", col=Bcol, lty = 1:9, pch=1:15, axes=FALSE, frame = TRUE, xlab = expression(epsilon), ylab = "relative error", main = expression(expm(A, method == "*") *" relative errors for " * A == bgroup("[", atop({-1} *" "* 1, {epsilon^2} *" "*{-1}), "]"))) legend("bottomright",colnames(t.m2), col=Bcol, lty = 1:9, pch=1:15, inset = 0.02) if(require("sfsmisc")) { sfsmisc::eaxis(1, labels=FALSE) sfsmisc::eaxis(1, at = eps[c(TRUE,FALSE)]) sfsmisc::eaxis(2) ## sfsmisc::eaxis(2, labels=FALSE) ## op <- par(las=2) ## sfsmisc::eaxis(2, at = axTicks(2,log=TRUE)[c(TRUE,FALSE,FALSE)]) ## par(op) } else { axis(1) axis(2) } ## typical case: ep <- 1e-10 (me <- m2ex3(ep)) me$expA * exp(1) ## the correct value ; numerically identical to simple matrix: ## identical() not fulfilled e.g. on Solaris stopifnot(all.equal(me$expA * exp(1), rbind(c( 1, 1), c(ep^2, 1)), tolerance = 1e-14)) ## The relative error (matrices): lapply(expmList, function(EXPM) 1 - EXPM(me$A)/me$expA) ## Average number of correct digits [less "extreme" than plot above] nDig <- sapply(expmList, function(EXPM) -log10(mean(abs(1 - EXPM(me$A)/me$expA)))) round(nDig, 2) ## Ward s.P.s s.P.sO s.T.s s.T.sO Eigen hybrid ## 16.26 14.65 14.65 14.65 14.65 6.20 6.39 [AMD Opteron 64-bit] ## Inf 14.65 14.65 14.65 14.65 6.74 6.33 [Pentium-M (32-bit)] ###--- rnilMat() : random upper triangular (zero-diagonal) nilpotent n x n matrix set.seed(17) m <- rnilMat(10) (m. <- as(m,"sparseMatrix"))# for nicer printing - and more *below* E.m <- expm::expm(m, method="Pade") as(E.m, "sparseMatrix") (dN <- 9*7*320) # 20160 stopifnot(abs(round(E.m * dN) - (E.m * dN)) < 9e-6) EmN <- matrix(c(dN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3*dN, dN, 0, 0, 0, 0, 0, 0, 0, 0, 352800, 5*dN, dN, 0, 0, 0, 0, 0, 0, 0, 1018080, 332640, 5*dN, dN, 0, 0, 0, 0, 0, 0, 2235240, 786240, 292320, 3*dN, dN, 0, 0, 0, 0, 0, 9368520, 3483480, 1582560, 413280, 181440, dN, 0, 0, 0, 0, 24676176, 9598680, 5073600, 1562400, 826560, 161280, dN, 0,0,0, 43730160, 17451000, 10051440, 3430560, 1955520, 504000, 5*dN, dN, 0, 0, 68438436, 27747480, 16853760, 6036240, 3638880, 1038240, 252000, 3*dN, dN, 0, 119725855, 49165892, 31046760, 11652480, 7198800, 2264640, 614880, 191520, 3*dN, dN), 10, 10) Em.xct <- EmN / dN stopifnot(all.equal(E.m, Em.xct, check.attributes = FALSE, tolerance= 1e-13)) re.x <- sapply(expmList, function(EXPM) relErr(Em.xct, EXPM(m))) ## with error message from "safe.Eigen" --> Eigen is NA here ## result depends quite a bit on platform which(is.na(re.x)) # gives c(Eigen = 16L) (but not everywhere ?!?) (re.x <- re.x[!is.na(re.x)]) ## Pentium-M 32-bit ubuntu gave ## Ward s.P.s s.P.sO sPs.H08. sPs.H08b s.T.s s.T.sO hybrid ## 1.079e-16 4.505e-14 4.503e-14 9.379e-17 9.379e-17 3.716e-17 7.079e-18 1.079e-16 ## 32-bit Quad-Core AMD Opteron 2380 (Linux 2.6.30.10-105.2.23.fc11.i686.PAE): ## Ward s.P.s s.P.sO sPs.H08. sPs.H08b s.T.s s.T.sO hybrid ## 1.079e-16 4.505e-14 4.503e-14 9.379e-17 9.379e-17 3.716e-17 7.079e-18 1.079e-16 ## "Ward77": again more accurate than s+Pade+s, but s+Taylor+s is even more accurate ## but on 64-bit AMD Opterons ## Ward s.P.s s.P.sO sPs.H08. sPs.H08b s.T.s s.T.sO hybrid ## 4.42e-17 3.99e-17 3.99e-17 1.10e-16 1.10e-16 8.44e-17 8.44e-17 4.42e-17 ## ## even more astonishing the result on Mac OSX (x86_32_mac; R-forge, R 2.9.0 patch.) ## Ward s.P.s s.P.sO sPs.H08. sPs.H08b s.T.s s.T.sO hybrid ## 5.13e-17 3.99e-17 3.99e-17 1.84e-15 1.84e-15 8.44e-17 8.44e-17 5.13e-17 ## 2014-09: AmHi09 are very good (64bit: 8e-17) for p >= 8 (p=6 has 1.5e-11) not.09.06 <- which(names(re.x) != "AmHi09.06") stopifnot(re.x[c("Ward", "s.T.s", "s.T.sO")] < 3e-16, re.x[["AmHi09.06"]] < 9e-11, # x64 & 686(lnx): = 1.509e-11 re.x[not.09.06] < 4e-13)# max: 686(32b): 4.52e-14, x64(lnx): 1.103e-16 ##-- Looking at *sparse* matrices: [C,Fortran "dense" code based methods will fail]: (meths <- eval(formals(expm)$method)) ems <- sapply(meths, function(met) tryCatch(expm::expm(m., method=met), error=identity)) ok <- !sapply(ems, is, class="error") meths[ok] # now most... are showProc.time() expm/tests/Frechet-test.R0000644000176200001440000000123712021132600015033 0ustar liggesuserslibrary(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE)# relErr() set.seed(101) for(n in c(1:5, 10:11, if(doExtras) 100:101 else 25)) { cat("n = ",n,"\n-----\n") for(i in seq_len(if(doExtras)10 else 3)) { A <- matrix(round(10*rnorm(n^2))/4, n,n) E <- matrix(rnorm(n^2, sd = 1e-3), n,n) F1 <- expmFrechet(A, E) F2 <- expmFrechet(A, E, "block") if(i == 1 && n < 9) print(F1) stopifnot(all.equal(F1, F2, tol = 6e-15 * n)) cat(sprintf("%5.2f ", relErr(F1 $ L, F2 $ L) * 2^52)) } cat(" * eps_C \n") } cat('Time elapsed: ', proc.time(), '\n') # for "statistical reasons" expm/tests/log+sqrt.R0000644000176200001440000000536312407501461014265 0ustar liggesuserslibrary(Matrix) library(expm) source(system.file("test-tools.R", package = "expm"), keep.source=FALSE) doExtras tst.sqrtm <- function(m, tol = 1e-12, zap.Im.tol = 1e-10) { r.m <- sqrtm(m)## should now work s <- r.m %*% r.m if(is.complex(s) && all(abs(Im(s)) < mean(abs(s)) * zap.Im.tol)) s <- Re(s) all.equal(m, s, tolerance=tol) } options(verbose = TRUE) # -> get some messages from logm.Higham ### ---- Small exact : ---------- L2 <- cbind(1, 0:1) lL2 <- cbind(0:1, 0) (L3 <- rbind(cbind(1,cbind(0:1,0)),1)) (lL3 <- cbind(rbind(0, cbind((2:1)/2,0:1)), 0)) assertError(logm(L2, method="Eigen")) assertError(logm(L3, method="Eigen")) logm.Higham08 <- expm:::logm.Higham08 l.L2 <- logm.Higham08(L2) l.L3 <- logm.Higham08(L3) all.equal(l.L2, lL2, tolerance=0)# 5.64 e-14 (32-bit *and* 64-bit) all.equal(l.L3, lL3, tolerance=0)# 2.40 e-15 (ditto) stopifnot(all.equal(l.L2, lL2, tolerance= 1000e-16), all.equal(l.L3, lL3, tolerance= 80e-16)) showProc.time() ### --------- More & larger randomly generated examples : ----------------- set.seed(101) EA <- expm.Higham08(A <- matrix(round(rnorm(25),1), 5)) all.equal(EA, expm.Higham08(logm.Higham08(EA)), tolerance=0) ## "Mean relative difference: 1.020137e-13" stopifnot(all.equal(EA, expm.Higham08(logm.Higham08(EA)), tolerance=1e-12)) S <- crossprod(A) all.equal(S, sqrtm(S) %*% sqrtm(S), tolerance=0) ## "Mean relative difference: 2.26885e-15" stopifnot(all.equal(S, sqrtm(S) %*% sqrtm(S), tolerance=1e-14)) showProc.time() set.seed(3) ## n = 50 is already "too" slow (well: logm.Higham08(.) needs 2.2 sec ## --> CPU measurements below for(n in c(2:5, 10:11, if(doExtras) 30)) { cat("n = ",n,": ") for(kk in seq_len(if(doExtras) 30 else 10)) { ## Testing logm() EA <- expm.Higham08(A <- matrix(round(rnorm(n^2),2), n,n)) stopifnot(all.equal(EA, expm.Higham08(logm.Higham08(EA)), tolerance=1e-12)) cat(" ") ## Testing sqrtm() --- for positive definite *and* arbitrary stopifnot(tst.sqrtm(A))# A is completely random S <- crossprod(A) + rnorm(n^2) / 1000 stopifnot(tst.sqrtm(S)) cat(".") } cat("\n") } showProc.time() ### CPU-measurements for logm() options(verbose = FALSE)# printing costs .. set.seed(5) if(doExtras) { n <- 50 sim <- 32 } else { n <- 21 sim <- 8 } cpuT <- numeric(sim) for(k in seq_len(sim)) { EA <- expm.Higham08(A <- matrix(rnorm(n^2), n,n)) cat(".") cpuT[k] <- system.time(LEA <- logm.Higham08(EA))[1] stopifnot(all.equal(EA, expm.Higham08(LEA), tolerance=1e-12)) }; cat("\n") summary(cpuT) ## cmath-5 {Feb.2009}; Michi's original code: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## 1.794 2.249 2.389 2.388 2.515 2.831 showProc.time() expm/tests/matpow-ex.R0000644000176200001440000000273313044611522014434 0ustar liggesuserslibrary(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE) ## -> assertError()... doExtras doExtras ## Missing REPROTECT(), till 2014-09-03 [because 'A' is *integer*]: set.seed(17) n <- 300 A <- matrix(rbinom(n^2, size=1, prob=0.1), n,n) A2 <- A %^% 2 for(i in 1:100) { A. <- A %^% 2 if(!isTRUE(all.equal(A2, A.))) cat("not equal; i=",i,"\n") } ## MM: On nb-mm3, I get a different error which shows memory corruption: ## REAL() can only be applied to a 'numeric', not a 'character' ## or REAL() can only be applied to a 'numeric', not a 'NULL' ## Check that *large* matrices now work if(FALSE) ## << even m %^% 2 takes > 20 hours (!!!) [but no longer stops early!] if(doExtras && require("sfsmisc") && exists("Sys.memGB", "package:sfsmisc", mode="function") && sfsmisc::Sys.memGB() > 50) { ## seems to need 3 x size(m) ## n <- 46341 print(as.integer(n^2))# integer overflow cat("Creating large matrix 'm' (more than max_int entries):\n ") print(system.time(m <- diag(x = (1:n)^3, nrow = n))) # 9.1 sec i <- 1:(n-1) print(system.time( m[cbind(i,i+1)] <- i )) # 11.3 sec cat("object.size(m): "); print(object.size(m), units="Gb") ## 16 Gb (= 17.78 e9 bytes) ## This __STILL__ takes hours cat("m %^% 2: "); print(system.time(m2 <- m %^% 2)) ## user system elapsed ## 127199.580 9608.373 137236.405 ==> cat("m %^% 4: "); print(system.time(m4 <- m %^% 4)) # } expm/tests/bal-ex.R0000644000176200001440000000715613777072735013713 0ustar liggesuserslibrary(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE)## -> assertError()... ## A matrix with 'Inf' mI <- rbind(0, c(-Inf, Inf, 0, 0), 0, 0) bal3 <- list(dB = dgebal(mI, "B"), # = default dP = dgebal(mI, "P"), dN = dgebal(mI, "N")) str(bal3) stopifnot(identical(mI, bal3$dN$z), with(bal3, all.equal(dB, dP, tol=1e-14)), all.equal(bal3$dB$z, rbind(c(Inf,-Inf,0,0), 0,0,0), tol=1e-14), all.equal(bal3$dB$scale, c(1,1,3,4))) assertError(dgebal(mI, "S"))# gave infinite loop ## Compare the two different "balance" pre-conditioning versions in Ward77: set.seed(1) mList <- lapply(integer(100), function(...) rSpMatrix(20, nnz=80)) re20 <- sapply(mList, function(M) relErr(expm(M, precond = "2bal"), expm(M, precond = "1bal"))) re20 ## ahh.: zero or ~ 1e-13 ... good table(re20 == 0) summary(re20[re20 != 0]) ## Pentium M (ubuntu) ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## 2.593e-14 8.703e-14 1.282e-13 2.434e-13 4.177e-13 6.295e-13 demo(balanceTst) #-> the function definition and the first few examples dm4. <- dgebal(m4) storage.mode(m4) <- "integer" stopifnot(identical(dm4., dgebal(m4))) expm(m) expm(m,"Pade") ## are different indeed {when bug still existed} expm(m,"R_Pade")# same as Pade ## a non-empty ``non-balanced'' example --- expm.t.identity(m4, "Ward") m6 <- zeroTrace(matrix(outer(2^(-8:9),c(-1,1)), 6,6)); m6 m6[lower.tri(m6)] <- 0 ## plus one non-zero m6[4,2] <- 77 p <- c(6,4,5,2:1,3); m6 <- m6[p,p] expm.t.identity(m6, "Ward") ## difference; indeed expm(m6) # is very different from expm(m6,"R_Pade") str(dm6 <- balanceTst(m6)) ## Now, that's interesting: ## ## 1. 'S' scales *more* (2 .. 5) than just (2:4 == i1:i2) ! ## ## 2. 'B' has quite different scaling and it does (must!) obey rule ## scale i1:i2 only ## ## 3. 'B'(oth) is better than "P" and "S" separately: ## kappa(eigen(m6)$vectors)# 597.5588 kappa(eigen(dm6$P$z)$vectors)# 597.5588 kappa(eigen(dm6$S$z)$vectors)# 42.58396 kappa(eigen(dm6$B$z)$vectors)# 22.20266 ## An n=17 example where octave's expm() is wrong too m17 <- matrix(c(10,0, 0, 2, 3,-1, 0, 0, 0, 0, 0, 4, 0, 5, 0, 0,-2, 0, 0, 0, 0,-3, 0, 0, 0, 0, 0, 0, 0, 0, 6, 0, 7, 0, 0, 0,10, 0, 0,-4, 9, 0, 0, 0,-5, 0,-6, 0, 0, 0, 0, 0, 0,-7, 0, 0, 0, 0, 0, 0,10, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0, 0, 0,12, 0, 0, 0, 0, 0,-8, 0, 0, 0, 0, 0, 0,-9, 0, 0, 0, 0, 0, 0,-10,0,13,14,-11,-12,-13, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,10, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-14,16,0,-10,0,17, 0, 0, 0, 0, 0, 0, 0, 0,-16,0, 0,18,19, 0, 0, 0, 0, 0, 0, 0,20, 0, 21, 22,0, 0, 0, 0, 0,-17,0, 0, 0,-10,-19,-20,0,0,0, 0, 0,-21,0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,23,24, 0,25,26, 0, 0,27,-22,0,28,-23,0,-24, 0,-25,0,29, 0, 0, 0, 0, 0, 0, 0,30,31, 0, 0, 0, 0, 0, 0,-26,32,0, 0, 0, 0, 0,-27,0,33,34, 0, 0, 0, 0, 0,-28,-29,0,0, 0,35, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,36,37, 0, 0, 0, 0, 0, 0, 0, 0,-10), 17, 17) str(dm17 <- balanceTst(m17)) sapply(dm17[1:3], `[[`, "scale") ## The balancing was really rather harmful -- cond(V) *not* improved: condX <- function(x) kappa(x, exact=TRUE) condX(eigen(m17)$vectors)# 8.9e16 condX(eigen(dm17$P$z)$vectors)# 1.37e17 condX(eigen(dm17$S$z)$vectors)# 1.44e17 condX(eigen(dm17$B$z)$vectors)# 1.43e17 (very slightly smaller) expm/tests/ex2.R0000644000176200001440000001267514547731226013234 0ustar liggesusers #### Example matrices from the Matlab demos // expAtv() examples library(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE) ## -> assertError()... doExtras ## --- 1 --- ## Here, all three {eigen; Taylor; Pade(Scaling & Squaring)} should do well A1 <- rbind(0:2, c(0.5, 0, 1), 2:0) A1 ml1 <- lapply(c(4:10,20), function(order) expm(A1, "Pade", order=order)) for(k in seq_len(length(ml1) - 1)) stopifnot(all.equal(ml1[[k]], ml1[[k + 1]], tolerance = 1e-12)) for(k in seq_len(length(ml1) - 1)) { print(all.equal(ml1[[k]], ml1[[k + 1]], tolerance = 0)) } mA1 <- ml1[[4]] stopifnot(all.equal(mA1, matrix(c(5.3090812852106, 2.8087900904073, 5.1737460019740, 4.0012030182399, 2.8845155413486, 4.0012030182399, 5.5778402926177, 3.1930144369526, 5.7131755758543), 3, 3), check.attributes = FALSE, tolerance = 1e-11)) ## --- 2 --- ## Here, Taylor "fails": ## A matrix where the terms in the Taylor series become very large ## before they go to zero. A2 <- rbind(c(-147, 72), c(-192, 93)) A2 (mA2 <- expm(A2, method="Pade")) stopifnot(all.equal(mA2, matrix(c(-0.099574136735459, -0.199148273470915, 0.074680602551593 , 0.149361205103183), 2, 2), check.attributes = FALSE, tolerance = 1e-11)) mA2.T <- expm(A2, method = "Taylor") stopifnot(all.equal(mA2, mA2.T, tolerance=1e-10)) all.equal(mA2, mA2.T, tolerance=1e-14)#-> 3.2e-12 {MM: I think that's pretty good} ## --- 3 --- ## Here, Eigenvalues must fail ("not a full set"): A3 <- rbind(c(-1, 1), c(0, -1)) (mA3 <- expm(A3, method="Pade")) assertError(expm(mA3, method="R_Eigen")) em1 <- exp(-1) stopifnot(all.equal(mA3, ## and the exact solution: matrix(c(em1, 0, em1, em1), 2, 2), check.attributes = FALSE, tolerance = 1e-14)) ## using 'eps' instead of 0 : ## ---> see m2ex3() etc in ./exact-ex.R ## --- 4 --- ## Here, some version of do_expm() failed: (m <- matrix(c(0,2:0),2)) ## Eigenvalue decomposition: d <- c(sqrt(2), -sqrt(2)) V <- rbind(c(sqrt(1/3), -sqrt(1/3)), c(sqrt(2/3), sqrt(2/3))) ## ==> IV <- rbind(c( sqrt(3/4), sqrt(3/8)), c(-sqrt(3/4), sqrt(3/8))) stopifnot(all.equal(V %*% IV, diag(2))) em.true <- V %*% (exp(d) * IV) stopifnot(all.equal(em.true, expm::expm(m)), all.equal(em.true, expm::expm(m,"Pade"), check.attributes=FALSE)) ###----------- expAtv() ---------------- ## Bug report, 8 Sep 2014 (R-forge Bugs item #5919), by: Peter Ralph stopifnot(expAtv(A3, v=c(0,0))$eAtv == 0) n <- 500 A <- bandSparse(n,n, -1:1, diagonals = list(-(2:n), -5*(1:n), 1:(n-1))) v <- 100*(n:1) t.v <- showSys.time(rr <- expAtv(A, v=v)) if(doExtras) { ## this is an order of magnitude slower : t.A <- system.time(w. <- (eA <- expm(A, "Higham08")) %*% v) stopifnot(all.equal(rr$eAtv, as.numeric(w.))) print( mean((t.A / t.v)[c(1,3)]) )## 23.57 {nb-mm3}; 21.0 {lynne} } ## Bug report on R-forge by Peter Ralph (petrelharp) ## If the entries of A are less than about 1e-8, then expAtv(A,v) fails ## with Error: length(d <- dim(x)) == 2 is not TRUE ## ... an error that comes from expm, because it has got a 1x1 matrix. (I can't tell why this causes an error; outside of expAtv this doesn't cause an error...) ## To reproduce: ##' @title Compute several "scaled" versions of e^{At} v : ##' @param A n x n matrix ##' @param v n vector ##' @param s vector of scales ##' @return list of expAtv() results ##' @author Martin Maechler, based on Peter Ralph's idea: scl.e.Atv <- function(A, v, s) { c(list(I = expAtv(A, v)), unlist(lapply(s, function(l) { ## cat(sprintf(" %7g\n", l)) list(lA = expAtv(l*A, v), lAI = expAtv(l*A, v, t=1/l)) }), recursive = FALSE)) } A <- matrix( 1:9, nrow=3 )/8 v <- rep(1,3) sc <- 4^c(-500, -200, -100, -5*(15:6), -2*(14:9), -17:15) ## 10^9 is too large => expm() "overflow" NaN r <- scl.e.Atv(A,v, s = sc) # at least without error (eAv <- t(sapply(r, `[[`, "eAtv"))) ## Ensure that indeed expAtv(A, v) =.= expAtv(e*A, v, 1/e) for e > 0 ## ----- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ eAv[1,] assert.EQ.mat(unname( eAv[rep(1, length(sc)), ]), unname( eAv[1+2*seq_along(sc), ] ), tol = 1e-14) # 64-bit lynne: 2.7e-16 !! sc.Atv <- function(A,v, s) { vapply(s, function(l) expAtv(l*A, v, t=1/l)$eAtv, v) } chk.sc.Atv <- function(A,v, s, tol=1e-15) { r <- vapply(s, function(l) expAtv(l*A, v, t=1/l)$eAtv, v) I <- expAtv(A,v)$eAtv if (!isTRUE(eq <- all.equal(as.vector(r), rep(I, length(s)), tolerance = tol))) stop("not all.equal() |-> ", eq) } chk.sc.Atv(A,v, sc, tol=1e-14) ## for information: see the precision: tryCatch( chk.sc.Atv(A,v, sc, tol= 0), error=identity)$message A0 <- matrix( c(-3,1,2,1,-2,1,0,1,-1), nrow=3, byrow=TRUE) A1 <- A0 + 1e-16*rnorm(9) ## These two also failed originally chk.sc.Atv(A0, v=10^(1:3), s=sc, tol=1e-14) chk.sc.Atv(A1, v=rep(1,3), s=sc, tol=1e-14) set.seed(17) S <- rSpMatrix(29, density = 1/64) v <- round(100*rnorm(nrow(S))) if(FALSE) ## Error in balance(baP$z, "S") : ## BLAS/LAPACK routine 'DGEBAL' gave error code -3 chk.sc.Atv(S/64, v, s=sc, tol=1e-14) if(FALSE) { ## after debug(chk.sc.Atv) ## this is revealing: image(as(relErrV(I, r),"sparseMatrix")) ## ==> sc[28:29] # are giving the largest differences } expm/tests/ex.R0000644000176200001440000002132714547727173013152 0ustar liggesuserslibrary(expm) (sI <- sessionInfo()) packageDescription("Matrix") packageDescription("expm") source(system.file("test-tools.R", package= "expm"), keep.source=FALSE) ## Note that these results are achieved with the default ## settings order=8, method="Pade" -- accuracy could ## presumably be improved still further by some tuning ## of these settings. ### Latest ATLAS (for BDR on F 36; R-devel Oct.2023) has much worse precision: ##==> use much larger tolerance in such cases: ## Simplified (needs R 3.4.0 and newer, from robustbase/inst/xtraR/platform-sessionInfo.R ) : BLAS <- extSoftVersion()[["BLAS"]] Lapack <- La_library() is.BLAS.Lapack <- identical(BLAS, Lapack) ## A cheap check (that works on KH's debian-gcc setup, 2019-05): if(!length(BLAS.is.openBLAS <- grepl("openblas", BLAS, ignore.case=TRUE))) BLAS.is.openBLAS <- NA if(!length(Lapack.is.openBLAS <- grepl("openblas", Lapack, ignore.case=TRUE))) Lapack.is.openBLAS <- NA (maybeATLAS <- is.BLAS.Lapack && !BLAS.is.openBLAS) ## ---------------------------- ## Test case 1 from Ward (1977) ## ---------------------------- T1 <- rbind(c(4, 2, 0), c(1, 4, 1), c(1, 1, 4)) (m1 <- expm(T1, method="Pade")) (m1O <- expm(T1, method="PadeO"))# very slightly different (m1T <- expm(T1, method="Taylor")) (m1TO <- expm(T1, method="TaylorO")) ## True Eigenvalue Decomposition of T1 s2 <- sqrt(2) eV1 <- matrix(c(s2,s2,s2, -2,1,1, 2,-1,-1) / sqrt(6), 3,3) L1 <- diag(lm1 <- c(6, 3, 3)) stopifnot( all.equal(eV1 %*% L1, T1 %*% eV1, tolerance=1e-15) ) ## However, eV1 is not orthogonal, but of rank 2 if(FALSE) { ## require("Rmpfr")) { ## 200 bit precision version of that S2 <- sqrt(mpfr(2,200)) E1 <- c(S2,S2,S2, -2,1,1, 2,-1,-1) / sqrt(mpfr(6,200)) dim(E1) <- c(3,3) print(E1 %*% L1) print(E1) } ## "true" result m1.t <- matrix(c(147.866622446369, 127.781085523181, 127.781085523182, 183.765138646367, 183.765138646366, 163.679601723179, 71.797032399996, 91.8825693231832, 111.968106246371), 3,3) stopifnot(all.equal(m1.t, m1, check.attributes=FALSE, tolerance = 1e-13), all.equal(m1.t, m1O, check.attributes=FALSE, tolerance = 1e-13), all.equal(m1.t,m1T, check.attributes=FALSE, tolerance = 1e-13), all.equal(m1.t,m1TO, check.attributes=FALSE, tolerance = 1e-13), all.equal(m1.t, expm(T1,"Ward77"), tolerance = 1e-13), all.equal(m1.t, expm(T1,"R_Pade"), tolerance = 1e-13), all.equal(m1.t, expm(T1,"R_Ward77"), tolerance = 1e-13)) ## -- these agree with ward (1977, p608) ## m1.2 <- try( expm(T1, "R_Eigen") ) ## 32-bit: gives an error from solve; 64-bit "ok" if(!inherits(m1.2, "try-error")) { if(FALSE)## with libatlas R_Eigen is "sehr eigen" stopifnot(all.equal(m1.t, m1.2, check.attributes=FALSE)) ## but it's less accurate: print( all.equal(m1.t, m1.2, check.attributes=FALSE, tolerance= 1e-12)) ##-> rel.diff = 6.44e-10 / 6.2023e-10 ##__ BUT 0.1228099 ##__ with libatlas (ubuntu 12.04 libatlas-base-dev Version: 3.8.4-3build1) } ## ## ---------------------------- ## Test case 2 from Ward (1977) ## ---------------------------- T2 <- t(matrix(c( 29.87942128909879, .7815750847907159, -2.289519314033932, .7815750847907159, 25.72656945571064, 8.680737820540137, -2.289519314033932, 8.680737820540137, 34.39400925519054), 3, 3)) (m2 <- expm(T2, method="Pade")) ## [,1] [,2] [,3] ##[1,] 5496313853692357 -18231880972009844 -30475770808580828 ##[2,] -18231880972009852 60605228702227024 101291842930256144 ##[3,] -30475770808580840 101291842930256144 169294411240859072 ## -- which agrees with Ward (1977) to 13 significant figures (m2O <- expm(T2, method="PadeO")) (m2T <- expm(T2,method="Taylor")) (m2TO <- expm(T2,method="TaylorO")) m2.t <- matrix(c(5496313853692216, -18231880972008932, -30475770808579672, -18231880972008928, 60605228702222480, 101291842930249776, -30475770808579672, 101291842930249808, 169294411240850528), 3, 3) ## -- in this case a very similar degree of accuracy -- even Taylor is ok stopifnot(all.equal(m2.t, m2, check.attributes=FALSE, tolerance = 1e-12), all.equal(m2.t, m2O,check.attributes=FALSE, tolerance = 1e-12), all.equal(m2.t,m2T, check.attributes=FALSE, tolerance = 1e-12), all.equal(m2.t,m2TO,check.attributes=FALSE, tolerance = 1e-12), all.equal(m2.t, expm(T2,"Ward77"), tolerance = 1e-12), all.equal(m2.t, expm(T2,"R_Ward77"), tolerance = 1e-12), all.equal(m2.t, expm(T2,"R_Pade"), tolerance = 1e-12), TRUE) ## ---------------------------- ## Test case 3 from Ward (1977) ## ---------------------------- T3 <- t(matrix(c( -131, 19, 18, -390, 56, 54, -387, 57, 52), 3, 3)) (m3 <- expm(T3, method="Pade")) ## [,1] [,2] [,3] ##[1,] -1.5096441587713636 0.36787943910439874 0.13533528117301735 ##[2,] -5.6325707997970271 1.47151775847745725 0.40600584351567010 ##[3,] -4.9349383260294299 1.10363831731417195 0.54134112675653534 ## -- agrees to 10dp with Ward (1977), p608. (m3O <- expm(T3, method="PadeO")) (m3T <- expm(T3,method="Taylor")) (m3TO <- expm(T3,method="TaylorO")) m3.t <- matrix(c(-1.50964415879218, -5.6325707998812, -4.934938326092, 0.367879439109187, 1.47151775849686, 1.10363831732856, 0.135335281175235, 0.406005843524598, 0.541341126763207), 3,3) stopifnot(all.equal(m3.t, m3, check.attributes=FALSE, tolerance = 3e-11), # ^^^^^ # 1.2455e-11 for libatlas (above) all.equal(m3.t, m3T, check.attributes=FALSE, tolerance = 1e-11), all.equal(m3.t, m3O, check.attributes=FALSE, tolerance = 8e-11),# M1: 1.39e-11 all.equal(m3.t, m3TO, check.attributes=FALSE, tolerance = 1e-11), all.equal(m3.t, expm(T3,"R_Eigen"), tolerance = 1e-11), all.equal(m3.t, expm(T3,"Ward77"), tolerance = 1e-11), all.equal(m3.t, expm(T3,"R_Ward"), tolerance = 1e-11), all.equal(m3.t, expm(T3,"R_Pade"), tolerance = 1e-11), TRUE) ## -- in this case, a similar level of agreement with Ward (1977). ## ---------------------------- ## Test case 4 from Ward (1977) ## ---------------------------- T4 <- array(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 1e-10, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0), dim = c(10, 10)) (m4 <- expm(T4, method="Pade")) (m4O <- expm(T4, method="PadeO")) (m4T <- expm(T4,method="Taylor")) (m4TO <- expm(T4,method="TaylorO")) ## ATLAS on BDR's gannet (Fedora 26; gcc-13; R-devel 2023-10-24) tol1 <- if(maybeATLAS) 4e-7 else 5e-15 # (m4, m4O) gave "Mean relative difference: 1.242879e-07" stopifnot(all.equal(m4 [,10], 1/gamma(10:1), tolerance=1e-14), all.equal(m4O [,10], 1/gamma(10:1), tolerance=1e-14), all.equal(m4T [,10], 1/gamma(10:1), tolerance=1e-14), all.equal(m4TO[,10], 1/gamma(10:1), tolerance=1e-14), all.equal(m4, m4O, check.attributes=FALSE, tolerance=tol1), all.equal(m4, m4T, check.attributes=FALSE, tolerance=tol1), all.equal(m4, m4TO,check.attributes=FALSE, tolerance=tol1), all.equal(m4, expm(T4,"Ward77"), check.attributes=FALSE, tolerance = 1e-14), all.equal(m4, expm(T4,"R_Ward"), check.attributes=FALSE, tolerance = 1e-14), all.equal(m4, expm(T4,"R_Pade"), check.attributes=FALSE, tolerance = 1e-14), max(abs(m4 - expm(T4,"R_Eigen"))) < 1e-7) ## here expm(., EV ) is accurate only to 7 d.p., whereas ## expm(.,Pade) is correct to at least 14 d.p. ### Test case with diagonalizable matrix with multiple Eigen values: A4 <- rbind(c(-1, 3, -1), c(-3, 5, -1), c(-3, 3, 1)) Ea4 <- eigen(A4) stopifnot(all.equal(Ea4$values, (lam4 <- c(2,2,1)))) ## However, the eigen values don't show the nice property: V4 <- Ea4$vectors crossprod(V4) ## i.e., they are *not* orthogonal ## but still diagonalize: stopifnot(all.equal(A4, V4 %*% diag(x=lam4) %*% solve(V4))) ## whereas this diagonalizes *and* looks nice W4 <- rbind(c(1, 1, -1), c(1, 1, 0), c(1, 0, 3)) (sW4 <- solve(W4)) assert.EQ(diag(x = c(1,2,2)), solve(W4) %*% A4 %*% W4, giveRE=TRUE) assert.EQ(A4, logm(expm(A4)), tol = 3e-13, giveRE=TRUE) ## seen 5.5e-14 with R's own matprod expm/src/0000755000176200001440000000000014547731256012030 5ustar liggesusersexpm/src/expm.h0000644000176200001440000000176113704012703013136 0ustar liggesusers #ifndef R_PKG_EXPM_H #define R_PKG_EXPM_H #define USE_FC_LEN_T #include #include #ifndef FCONE # define FCONE #endif #include #include #include #include #include "R_NLS_locale.h" typedef enum {Ward_2, Ward_1, Ward_buggy_octave} precond_type; SEXP R_dgebal(SEXP x, SEXP type); SEXP do_expm(SEXP x, SEXP kind); void expm(double *x, int n, double *z, precond_type precond_kind); SEXP R_matexp_MH09(SEXP x, SEXP p); void matexp_MH09(double *x, int n, const int p, double *ret); // The legacy code: ----------------------------- // matexp.f: matexpRBS << is what I'd want int F77_NAME(matexprbs)(int *ideg, int *m, double *t, double *H, int *iflag); // matrexp.f: int F77_NAME(matrexp)(double* a, int* n, int* ntaylor, int* npade, double* accuracy); // matrexpO.f: matrexpO << is what I'd want int F77_NAME(matrexpo)(double* a, int* n, int* ntaylor, int* npade, double* accuracy); #endif /* R_PKG_EXPM_H */ expm/src/matrexpO.f0000644000176200001440000002060512470350137013765 0ustar liggesusersc This program computes exp(A) for a given matrix A. c c 2 algorithms are employed: c 1. The Taylor expansion of order "ntaylor," denoted by T(ntaylor). c 2. The Pade diagonal approximation of order c "npade" denoted by P(npade), is used instead, IFF ntaylor = 0 c The algorithm is applied twice to calculate c T(ntaylor) and T(ntaylor+10) [or, when ntaylor=0, c to calculate P(npade) and P(npade+10)]. c An upper bound for the L2 norm of the Cauchy error c T(ntaylor+10)-T(ntaylor) [or, when ntaylor=0, c P(npade+10)-P(npade)] is computed. c The result exp(A) is returned via the first argument. c c This version works with R (i.e., is written as a subroutine) c c To use it, first do c % R SHLIB matrexp.f c to make the shared library matrexp.so c c and then in R, c > dyn.load("matrexp.so") c > .C("matrexp_",as.double(runif(9)), c as.integer(3),as.integer(0),as.integer(8)) c c (This is all done automatically in the R package "expm".) c c -- MM: This is *legacy* code - but we provide the "padeO" ... methods c -- ===> Fix the fortran code enough that it does not give "--as-cran" warnings: c subroutine matrexpO(a, ndim, ntaylor, npade, accuracy) integer ndim, ntaylor, npade double precision a(ndim,ndim), accuracy c "ndim" is the order of the given matrix A c double precision sum(ndim,ndim) double precision solution(ndim,ndim) double precision error(ndim,ndim) double precision dkeep(ndim,ndim) double precision dsqrt, dl1norm, dlinfnorm integer log2 c c use the algorithm to compute T(ntaylor) or P(npade) c npower=log2(dsqrt(dl1norm(ndim,a)*dlinfnorm(ndim,a)))+4 if(ntaylor.gt.0)then call taylorO(ndim,ntaylor,npower,a,sum) else call padeO(ndim,npade,npower,a,sum) endif call powermatrix(ndim,sum,npower,dkeep) call id(ndim,dkeep,sum) c c computing the "solution" T(ntaylor+10) or P(npade+10) c if(ntaylor.gt.0)then call taylorO(ndim,ntaylor+10,npower,a,solution) else call padeO(ndim,npade+10,npower,a,solution) endif call powermatrix(ndim,solution,npower,dkeep) call id(ndim,dkeep,solution) c c copy the result back into a c do i=1,ndim do j=1,ndim a(i,j) = sum(i,j) end do end do c c compute the Cauchy error T(ntaylor+10)-T(ntaylor) c or P(npade+10)-P(npade) c call subtract(ndim,sum,solution,error) accuracy = dsqrt(dl1norm(ndim,error)*dlinfnorm(ndim,error)) return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine taylorO(m,ntaylor,npower,a,sum) c Taylor series for exp(a/2**npower) implicit double precision (a-h,o-z) double precision a(m,m),sum(m,m),dkeep(m,m) nscale=2**npower c print*,'A is scaled by 2**',npower,' =',nscale call initialize(m,sum,0.d0) call addtodiag(m,sum,1.d0) do n=ntaylor,1,-1 call multiplymatrixO(m,sum,a,dkeep) call multiplyscalarO(m,dkeep,1.d0/dble(n*nscale),sum) call addtodiag(m,sum,1.d0) end do return end subroutine padeO(m,npade,npower,a,approx) c Pade approximation for exp(a/2**npower) integer m, npade, npower double precision a(m,m), approx(m,m) c Var double precision aminus(m,m),dkeep(m,m) double precision padenom(m,m),padedenom(m,m) integer nscale,n,i nscale=2**npower c print*,'A is scaled by 2**',npower,' =',nscale call initialize(m,padenom,0.d0) call addtodiag(m,padenom,1.d0) do n=npade,1,-1 call multiplymatrixO(m,padenom,a,dkeep) call multiplyscalarO(m,dkeep, $ dble(npade-n+1)/dble(n*(2*npade-n+1)*nscale),padenom) call addtodiag(m,padenom,1.d0) end do call minus(m,a,aminus) call initialize(m,padedenom,0.d0) call addtodiag(m,padedenom,1.d0) do n=npade,1,-1 call multiplymatrixO(m,padedenom,aminus,dkeep) call multiplyscalarO(m,dkeep, $ dble(npade-n+1)/dble(n*(2*npade-n+1)*nscale),padedenom) call addtodiag(m,padedenom,1.d0) end do do i=1,m call solveO(m,padedenom,padenom(1,i),approx(1,i)) end do return end c MM: FIXME: Use BLAS for the following !!! c ----- (also R internal things --> use C, not Fortran ! c initializing a matrix to a scalar s subroutine initialize(m,x,s) integer m double precision x(m,m), s integer i,j do i=1,m do j=1,m x(i,j)=s end do end do return end subroutine multiplyscalarO(m,x,s,y) c multiplying a matrix x by a scalar s implicit double precision (a-h,o-z) double precision x(m,m),y(m,m) do i=1,m do j=1,m y(i,j)=x(i,j)*s end do end do return end subroutine multiplymatrixO(m,x,y,z) c multiplying 2 matrices implicit double precision (a-h,o-z) double precision x(m,m),y(m,m),z(m,m) do i=1,m do j=1,m z(i,j)=0.d0 do k=1,m z(i,j)=z(i,j)+x(i,k)*y(k,j) end do end do end do return end subroutine id(m,x,y) c assign a matrix x to y implicit double precision (a-h,o-z) double precision x(m,m),y(m,m) do i=1,m do j=1,m y(i,j)=x(i,j) end do end do return end subroutine powermatrix(m,x,ipower,y) c computing the ith power of a matrix x implicit double precision (a-h,o-z) double precision x(m,m),y(m,m),dkeep(m,m) call id(m,x,y) call id(m,x,dkeep) do i=1,ipower call multiplymatrixO(m,dkeep,dkeep,y) call id(m,y,dkeep) end do return end subroutine iden(m,x,y) c assign a vector x to y implicit double precision (a-h,o-z) double precision x(m),y(m) do i=1,m y(i)=x(i) end do return end double precision function dip(m,u,v) c inner product of 2 vectors integer m double precision u(m),v(m) integer i dip=0.d0 do i=1,m dip = dip+u(i)*v(i) end do return end double precision function dl2norm(m,u) c l2 norm of a vector implicit double precision (a-h,o-z) double precision u(m) dl2norm=dsqrt(dip(m,u,u)) return end subroutine solveO(m,A,f,x) c CGS iteration integer m double precision A(m,m), f(m), x(m) c double precision save(m),rcgs(m),r(m) double precision p(m),u(m) double precision rbar(m),v(m),q(m) external dl2norm, dip double precision dl2norm, dip double precision alpha, beta, thresh, eps, omega0,omega1, + omegainit, rho0,rho1, scalar,sigma, tau,vv integer l thresh=1.d-100 eps=1.d-30 call zero(m,x) call iden(m,f,r) call iden(m,r,rcgs) call iden(m,r,p) call iden(m,r,u) omega0= dl2norm(m,rcgs) omegainit=omega0 c print*,'res0=',dabs(omegainit) tau=omega0 vv=0.d0 eta=0.d0 call iden(m,r,rbar) rho0= dip(m,rbar,r) if(dabs(rho0).le.thresh)then c print*,'rho0=',rho0,' MG iteration number=1' return endif do l=1,m call multiplyvector(m,A,p,v) sigma=dip(m,rbar,v) if(dabs(sigma).le.thresh)then c print*,'sigma=',sigma,' iteration number=',2*l+1 return endif alpha=rho0/sigma if(dabs(alpha).le.thresh)then c print*,'alpha=',alpha,' iteration number=',2*l+1 return endif scalar=-alpha call comb(m,u,scalar,v,q) call add(m,u,q,v) call multiplyvector(m,A,v,save) call comb(m,rcgs,scalar,save,rcgs) omega1=dl2norm(m,rcgs) call comb(m,x,alpha,v,x) c print*,'residual=',dabs(omega1),' iteration number=',2*l+1 if(dabs(omega1/omegainit).le.eps)then c print*,'iteration number=',2*l+1 return endif omega0=omega1 rho1=dip(m,rbar,rcgs) if(dabs(rho1).le.thresh)then c print*,'rho1=',rho1,' iteration number=',2*l+1 return endif beta=rho1/rho0 rho0=rho1 call comb(m,rcgs,beta,q,u) call comb(m,q,beta,p,save) call comb(m,u,beta,save,p) end do c print*,'iteration number=',2*l+1 return end expm/src/matpow.h0000644000176200001440000000022013704012703013461 0ustar liggesusers#include "expm.h" /* The C API :*/ void matpow(double *x, int n, int k, double *z); /* as .Call()ed from R */ SEXP R_matpow(SEXP x, SEXP k); expm/src/expm-eigen.c0000644000176200001440000001762513704012703014224 0ustar liggesusers/* ===== File part of R package expm ===== * * Function to compute the matrix exponential * * exp(M) = sum(n = 0:Inf; M^n / n!), * * where M is an (n x n) matrix. * * The functions therein use LAPACK and BLAS routines. Nicely * formatted man pages for these can be found at * * * * AUTHORS: Christophe Dutang, based on code eigen, * * i.e., function 'modLa_rg' and 'modLa_dgesv' in R's * /src/modules/lapack/lapack.c, used in eigen() */ #include "expm-eigen.h" void expm_eigen(double *x, int n, double *z, double tol) { if (n == 1) z[0] = exp(x[0]); /* scalar exponential */ else { const int nsqr = n * n; const Rcomplex cone = {1., 0.}, czero = {0., 0.}; int i, j; int info, lwork, is_conjug, is_diag; double onenorm, rcond, tmp; /* Arrays */ int *ipiv = (int *) R_alloc(n, sizeof(int)); /* permutation vector */ double *left, *right, *workdiag; /* left and right eigenvectors and workspace for diagonalisation */ double *wR = (double *) R_alloc(n, sizeof(double)); /* real part of eigenvalues */ double *wI = (double *) R_alloc(n, sizeof(double)); /* imaginary part of eigenvalues */ double *rworksing = (double *) R_alloc(2*n, sizeof(double)); /* working vector to test the singularity */ Rcomplex *eigvect = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* (right) eigenvectors matrix */ Rcomplex *eigvectinv = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* its inverse */ Rcomplex *expeigval; /* complex matrix diag(exp(eigenvalues)) */ Rcomplex *ctmp = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* temp working variable */ Rcomplex *worksing = (Rcomplex *) R_alloc(2*n, sizeof(Rcomplex)); /* workspace to test the singularity */ Memcpy(z, x, nsqr); /* Test if x is diagonalisable by computing its eigenvalues and (right) eigenvectors */ /* code based on modLa_rg in lapack.c, used in eigen.R */ left = (double *) 0; right = (double *) R_alloc(nsqr, sizeof(double)); /* 1 - ask for optimal size of work array */ lwork = -1; F77_CALL(dgeev)("N", "V", &n, z, &n, wR, wI, left, &n, right, &n, &tmp, &lwork, &info FCONE FCONE); if (info != 0) error(_("error code %d from Lapack routine dgeev"), info); lwork = (int) tmp; workdiag = (double *) R_alloc(lwork, sizeof(double)); /* 2 - compute eigenvalues and (right) eigenvectors */ F77_CALL(dgeev)("N", "V", &n, z, &n, wR, wI, left, &n, right, &n, workdiag, &lwork, &info FCONE FCONE); if (info != 0) error(_("error code %d from Lapack routine dgeev"), info); /* try to invert the eigenvectors matrix */ /* 1 - build the Rcomplex matrix with eigenvectors */ for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { is_conjug = 0; if(i < n-1) { /* conjugate eigenvalues */ if(wR[i] == wR[i+1] && wI[i] == -wI[i+1] && wI[i] != 0.0) { is_conjug = 1; eigvect[i * n + j].r = right[i * n + j]; eigvect[i * n + j].i = right[(i+1) * n + j]; } } if(i > 0) { /* conjugate eigenvalues */ if(wR[i] == wR[i-1] && wI[i] == -wI[i-1] && wI[i] != 0.0) { is_conjug = 1; eigvect[i * n + j].r = right[(i-1) * n + j]; eigvect[i * n + j].i = -right[i * n + j]; } } /* real eigenvalues */ if(!is_conjug) { eigvect[i * n + j].r = right[i * n + j]; eigvect[i * n + j].i = 0.0; } /* eigvectinv initialise with the identity matrix */ eigvectinv[i * n +j].r = (i == j) ? 1.0 : 0.0; eigvectinv[i * n +j].i = 0.0; } } /* 2 - store the matrix eigvect (because function zgesv will change it) */ Memcpy(ctmp, eigvect, nsqr); /* 3 - solve a linear complex equation system with eigvectinv equals * to matrix identity. hence, on exit eigvectinv contains the * inverse of complex matrix eigvect. code base on solve.R */ F77_CALL(zgesv)(&n, &n, eigvect, &n, ipiv, eigvectinv, &n, &info); if (info > 0) is_diag = 0; //matrix eigvect is exactly singular. if (info < 0) error(_("argument %d of Lapack routine dgesv had invalid value"), -info); if (info == 0) is_diag = 1; /* check if matrix eigvectinv is numerically singular */ if (is_diag) { /* compute the reciprocal condition number of eigvectinv. */ /* 1 - compute the one norm of the matrix eigvectinv */ onenorm = F77_CALL(zlange)("1", &n, &n, eigvectinv, &n, (double*) NULL FCONE); /* 2 - estimates the reciprocal of the condition number * when the one norm is used. */ F77_CALL(zgecon)("1", &n, eigvectinv, &n, &onenorm, &rcond, worksing, rworksing, &info FCONE); if (rcond < tol) is_diag=0; } if (is_diag) { /* x is diagonalisable so * compute complex matrix operations : * eigvect %*% diag(exp(eigenvalues)) %*% eigvectinv */ /* 1 - expeigval is the complex matrix diag(exp(eigenvalues)) */ /* code based on z_exp in complex.c */ expeigval = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { if(i == j) { expeigval[i * n +j].r = exp(wR[i]) * cos(wI[i]); expeigval[i * n +j].i = exp(wR[i]) * sin(wI[i]); } else { expeigval[i * n +j].r = 0.0; expeigval[i * n +j].i = 0.0; } } } /* 2 - restore the matrix eigvect */ Memcpy(eigvect, ctmp, nsqr); /* 3 - compute (complex) matrix product: ctmp <- eigvect * expeigval */ F77_CALL(zgemm)("N", "N", &n, &n, &n, &cone, eigvect, &n, expeigval, &n, &czero, ctmp, &n FCONE FCONE); /* 4 - compute (complex) matrix product: expeigval <- ctmp * eigvectinv */ F77_CALL(zgemm)("N", "N", &n, &n, &n, &cone, ctmp, &n, eigvectinv, &n, &czero, expeigval, &n FCONE FCONE); /* store the real part in z */ /* the matrix exponential is always real, * even if x has complex eigen values. */ for (i = 0; i < n; i++) for (j = 0; j < n; j++) z[i * n + j] = expeigval[i * n + j].r; } else expm(x, n, z, Ward_2); } } /* Main function, the only one used by .Call(). */ SEXP do_expm_eigen(SEXP x, SEXP tolin) { SEXP dims, z; int n, nprot = 0; double *rx, *rz; double tol = asReal(tolin); if (!isNumeric(x) || !isMatrix(x)) error(_("invalid argument: not a numeric matrix")); if (isInteger(x)) { x = PROTECT(coerceVector(x, REALSXP)); nprot++; } rx = REAL(x); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; if (n != INTEGER(dims)[1]) error(_("non-square matrix")); if (n == 0) { UNPROTECT(nprot); return(allocMatrix(REALSXP, 0, 0)); } PROTECT(z = allocMatrix(REALSXP, n, n)); nprot++; rz = REAL(z); expm_eigen(rx, n, rz, tol); setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(nprot); return z; } expm/src/matexp.f0000644000176200001440000001320411652733737013475 0ustar liggesusers!-----------------------------------------------------------------------! ! ! ! V A R I O U S M A T H E M A T I C A L U T I L I T I E S ! ! ! ! FORTRAN 77 PROCEDURES ! !-----------------------------------------------------------------------! !-----------------------------------------------------------------------! subroutine matexpRBS (ideg, m, t, H, iflag) IMPLICIT NONE INTEGER ideg, m, iflag DOUBLE PRECISION t, H(m,m) !-----PURPOSE-----------------------------------------------------------! ! ! COMPUTES EXP(T*H), THE MATRIX EXPONENTIAL OF A GENERAL MATRIX IN ! FULL, USING THE IRREDUCIBLE RATIONAL PADE APPROXIMATION TO THE ! EXPONENTIAL FUNCTION EXP(X) = R(X) = (+/-)( I + 2*(Q(X)/P(X)) ), ! COMBINED WITH SCALING-AND-SQUARING. ! !-----ARGUMENTS---------------------------------------------------------! ! ! IDEG : (INPUT) THE DEGREE OF THE DIAGONAL PADE TO BE USED. ! A VALUE OF 6 IS GENERALLY SATISFACTORY. ! ! M : (INPUT) ORDER OF H. ! ! T : (INPUT) TIME-SCALE (CAN BE < 0). ! ! H(M,M) : (INPUT) ARGUMENT MATRIX. ! ! IFLAG : (OUTPUT) EXIT FLAG. ! 0 - NO PROBLEM ! <0 - PROBLEM ! !-----------------------------------------------------------------------! ! ROGER B. SIDJE (RBS@MATHS.UQ.EDU.AU) - 'RBS' ! EXPOKIT: SOFTWARE PACKAGE FOR COMPUTING MATRIX EXPONENTIALS. ! ACM - TRANSACTIONS ON MATHEMATICAL SOFTWARE, 24(1):130-156, 1998 !-----------------------------------------------------------------------! ! MODIFIED TO RETURN A FLAG INSTEAD OF TERMINATING, WHEN TRYING ! TO COMPUTE THE EXPONENTIAL OF A MATRIX WITH TOO LARGE ELEMENTS. ! ! 1) NIELS RODE KRISTENSEN, TECHNICAL UNIVERSITY OF DENMARK, 2000 ! 2) ANDREAS S. CHRISTENSEN,TECHNICAL UNIVERSITY OF DENMARK, 2006 ! 3) SREN KLIM, IMM-DTU, 2007 !-----------------------------------------------------------------------! ! INTEGER LWSP, NS, IPIV(M) DOUBLE PRECISION WSP(4*M*M+IDEG+1) INTEGER MM,I,J,K,IH2,IP,IQ,IUSED,IFREE,IODD,ICOEF,IPUT,IGET DOUBLE PRECISION HNORM,SCALE,SCALE2,CP,CQ ! "External" routines: INTRINSIC INT,ABS,DBLE,LOG,MAX !--- CHECK RESTRICTIONS ON INPUT PARAMETERS ... MM = M*M IFLAG = 0 LWSP = 4*M*M + IDEG +1 ! !--- INITIALISE POINTERS ... ! ICOEF = 1 IH2 = ICOEF + (IDEG+1) IP = IH2 + MM IQ = IP + MM IFREE = IQ + MM NS=0 ! !--- INITIALISE ARRAYS ... ! DO I = 1, LWSP WSP(I) = 0.0D0 ENDDO DO I = 1, M IPIV(I) = 0 ENDDO ! !--- SCALING: SEEK NS SUCH THAT ||T*H/2^NS|| < 1/2; ! AND SET SCALE = T/2^NS ... ! DO J = 1,M DO I = 1,M WSP(I) = WSP(I) + ABS( H(I,J) ) ENDDO ENDDO HNORM = 0.0D0 DO I = 1,M HNORM = MAX( HNORM,WSP(I) ) ENDDO HNORM = ABS( T*HNORM ) IF (HNORM .EQ. 0.D0) + CALL RExit('ERROR - NULL H IN INPUT OF DGPADM.') NS = MAX(0, INT(LOG(HNORM)/LOG(2.))+2) SCALE = T / DBLE(2**NS) SCALE2 = SCALE*SCALE ! !--- COMPUTE PADE COEFFICIENTS ... ! I = IDEG+1 J = 2*IDEG+1 WSP(ICOEF) = 1.0D0 DO K = 1,IDEG WSP(ICOEF+K) = (WSP(ICOEF+K-1)*DBLE( I-K ))/DBLE( K*(J-K) ) ENDDO ! !--- H2 = SCALE2*H*H ... ! CALL DGEMM( 'N','N',M,M,M,SCALE2,H,M,H,M,0.0D0,WSP(IH2),M ) ! !--- INITIALIZE P (NUMERATOR) AND Q (DENOMINATOR) ... ! CP = WSP(ICOEF+IDEG-1) CQ = WSP(ICOEF+IDEG) DO J = 1,M DO I = 1,M WSP(IP + (J-1)*M + I-1) = 0.0D0 WSP(IQ + (J-1)*M + I-1) = 0.0D0 ENDDO WSP(IP + (J-1)*(M+1)) = CP WSP(IQ + (J-1)*(M+1)) = CQ ENDDO ! !--- APPLY HORNER RULE ... ! IODD = 1 K = IDEG - 1 100 CONTINUE IUSED = IODD*IQ + (1-IODD)*IP CALL DGEMM( 'N','N',M,M,M, 1.0D0,WSP(IUSED),M, . WSP(IH2),M, 0.0D0,WSP(IFREE),M ) DO J = 1,M WSP(IFREE+(J-1)*(M+1)) = WSP(IFREE+(J-1)*(M+1))+WSP(ICOEF+K-1) ENDDO IP = (1-IODD)*IFREE + IODD*IP IQ = IODD*IFREE + (1-IODD)*IQ IFREE = IUSED IODD = 1-IODD K = K-1 IF ( K.GT.0 ) GOTO 100 ! !--- OBTAIN (+/-)(I + 2*(P\Q)) ... ! IF ( IODD .EQ. 1 ) THEN CALL DGEMM( 'N','N',M,M,M, SCALE,WSP(IQ),M, . H,M, 0.0D0,WSP(IFREE),M ) IQ = IFREE ELSE CALL DGEMM( 'N','N',M,M,M, SCALE,WSP(IP),M, . H,M, 0.0D0,WSP(IFREE),M ) IP = IFREE ENDIF CALL DAXPY( MM, -1.0D0,WSP(IP),1, WSP(IQ),1 ) CALL DGESV( M,M, WSP(IQ),M, IPIV, WSP(IP),M, IFLAG ) IF ( IFLAG.NE.0 ) CALL RWarn ('PROBLEM IN DGESV (WITHIN DGPADM)') CALL DSCAL( MM, 2.0D0, WSP(IP), 1 ) DO J = 1,M WSP(IP+(J-1)*(M+1)) = WSP(IP+(J-1)*(M+1)) + 1.0D0 ENDDO IPUT = IP IF ( NS.EQ.0 .AND. IODD.EQ.1 ) THEN CALL DSCAL( MM, -1.0D0, WSP(IP), 1 ) ELSE !--- SQUARING : EXP(T*H) = (EXP(T*H))^(2^NS) ... ! IODD = 1 DO K = 1,NS IGET = IODD*IP + (1-IODD)*IQ IPUT = (1-IODD)*IP + IODD*IQ CALL DGEMM( 'N','N',M,M,M, 1.0D0,WSP(IGET),M, WSP(IGET),M, . 0.0D0,WSP(IPUT),M ) IODD = 1-IODD ENDDO ENDIF !--- COPY EXP(H*T) into H DO I= 1,M DO J=1,M H(I,J) = WSP(IPUT +(I-1) + (J-1)*M) ENDDO ENDDO !-----------------------------------------------------------------------! END expm/src/init.c0000644000176200001440000000262213066656526013142 0ustar liggesusers/* * Native routines registration */ #include #include #include // for NULL #include #include "expm-eigen.h" #include "expm.h" #include "logm-eigen.h" #include "matpow.h" static const R_CallMethodDef CallEntries[] = { {"do_expm", (DL_FUNC) &do_expm, 2}, {"R_matpow", (DL_FUNC) &R_matpow, 2}, {"R_dgebal", (DL_FUNC) &R_dgebal, 2}, {"do_expm_eigen", (DL_FUNC) &do_expm_eigen, 2}, {"do_logm_eigen", (DL_FUNC) &do_logm_eigen, 2}, {"R_matexp_MH09", (DL_FUNC) &R_matexp_MH09, 2}, {NULL, NULL, 0} }; static const R_FortranMethodDef FortEntries[] = { {"matexpRBS", (DL_FUNC) &F77_SUB(matexprbs), 5}, // ./matexp.f {"matrexp", (DL_FUNC) &F77_SUB(matrexp), 5}, // ./matrexp.f {"matrexpO", (DL_FUNC) &F77_SUB(matrexpo), 5}, // ./matrexpO.f {NULL, NULL, 0} }; void R_init_expm(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, FortEntries, NULL); R_useDynamicSymbols(dll, FALSE); /* callable C code from other packages C code :*/ R_RegisterCCallable("expm", "expm", (DL_FUNC) expm); R_RegisterCCallable("matpow", "matpow", (DL_FUNC) matpow); R_RegisterCCallable("expm_eigen", "expm_eigen", (DL_FUNC) expm_eigen); R_RegisterCCallable("logm_eigen", "logm_eigen", (DL_FUNC) logm_eigen); R_RegisterCCallable("matexp_MH09", "matexp_MH09", (DL_FUNC) matexp_MH09); } expm/src/mexp-common.f0000644000176200001440000000664112470365777014451 0ustar liggesusersC--- Common to "Original" (Old) matrexpO() -- ./matrexpO.f C--- and to new potentially BLAS-based matrexp() -- ./matrexp.f subroutine subtract(m,x,y,z) c subtracting a matrix y from a matrix x integer m double precision x(m,m),y(m,m),z(m,m) integer i,j do i=1,m do j=1,m z(i,j)=x(i,j)-y(i,j) enddo enddo return end subroutine addtodiag(m,x,s) c add a scalar s to the main diagonal elements of a matrix x integer m double precision x(m,m), s integer i do i=1,m x(i,i)=x(i,i)+s enddo return end subroutine minus(m,x,y) c the minus of a matrix integer m double precision x(m,m),y(m,m) integer i,j do i=1,m do j=1,m y(i,j)=-x(i,j) enddo enddo return end double precision function dl1norm(m,x) c L_1 norm of a matrix := max_j sum_i |x_{ij}| integer m double precision x(m,m) double precision sum integer j,i dl1norm=0.d0 do i=1,m sum=0.d0 do j=1,m sum=sum+dabs(x(j,i)) enddo if(sum.gt.dl1norm) dl1norm=sum enddo return end double precision function dlinfnorm(m,x) c L_infty norm of a matrix := max_i sum_j |x_{ij}| integer m double precision x(m,m) double precision sum integer i,j dlinfnorm=0.d0 do i=1,m sum=0.d0 do j=1,m sum=sum+dabs(x(i,j)) enddo if(sum.gt.dlinfnorm) dlinfnorm=sum enddo return end subroutine zero(m,x) c zeroing a vector integer m double precision x(m) integer i do i=1,m x(i)=0.d0 enddo end subroutine add(m,x,y,z) c adding 2 vectors z[] := x[] + y[] integer m double precision x(m),y(m),z(m) integer i do i=1,m z(i)=x(i)+y(i) enddo return end subroutine sub(m,x,y,z) c subtracting a vector y from a vector x integer m double precision x(m),y(m),z(m) integer i do i=1,m z(i)=x(i)-y(i) enddo return end subroutine comb(m,x,a,y,z) c linear combination of 2 vectors z[] := x[] + a* y[] integer m double precision a, x(m),y(m),z(m) integer i do i=1,m z(i)=x(i)+a*y(i) enddo return end subroutine multiplyvector(m,a,x,y) c multiplying matrix times vector y := A . x integer m double precision a(m,m),x(m),y(m) integer i,j do i=1,m y(i) = 0d0 do j=1,m y(i)=y(i)+a(i,j)*x(j) enddo enddo return end integer function log2(x) c the least integer larger than log_2(x) double precision x log2=0 8 log2 = log2+1 if(dble(2**log2).lt.x) goto 8 return end integer function nfact(n) c factorial function integer n integer i nfact=1 do i=1,n nfact=nfact*i enddo return end double precision function c(n,k) c kth coefficient in the nth Pade polynom integer n,k double precision padenom, padedenom integer nfact padenom=dble(nfact(2*n-k)*nfact(n)) padedenom=dble(nfact(2*n)*nfact(k)*nfact(n-k)) c=padenom/padedenom return end expm/src/matpow.c0000644000176200001440000000456113704012703013470 0ustar liggesusers/* * Power of a matrix x^k := x x ... x, where x in an (n x n) matrix * and k is an *integer*. Based on code originally written by Vincent * Goulet for package actuar (and inspired from Octave in file * .../src/xpow.cc) with slight shortcuts by Martin Maechler: */ #include "matpow.h" /* .Call() this from R : */ SEXP R_matpow(SEXP x, SEXP k) { if(!isMatrix(x)) { error(_("not a matrix")); /*-Wall */ return R_NilValue; } else { SEXP dims = getAttrib(x, R_DimSymbol); int n = INTEGER(dims)[0], k_ = INTEGER(k)[0]; /* need copy, as it is altered in matpow() */ if (n != INTEGER(dims)[1]) error(_("non-square matrix")); if (n == 0) return(allocMatrix(REALSXP, 0, 0)); SEXP x_ = duplicate(x); PROTECT_INDEX xpi; PROTECT_WITH_INDEX(x_, &xpi); if (!isReal(x)) /* coercion to numeric */ REPROTECT(x_ = coerceVector(x_, REALSXP), xpi); SEXP z = PROTECT(allocMatrix(REALSXP, n, n)); setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); matpow(REAL(x_), n, k_, REAL(z)); UNPROTECT(2); return z; } } /* Compute z := x %^% k, x an (n x n) square "matrix" in column-order; * NB: x will be altered! The caller must make a copy if needed */ void matpow(double *x, int n, int k, double *z) { if (k == 0) { /* return identity matrix */ int i, j; for (i = 0; i < n; i++) for (j = 0; j < n; j++) z[i * n + j] = (i == j) ? 1.0 : 0.0; return; } else if (k < 0) { error(_("power must be a positive integer; use solve() directly for negative powers")); } else { /* k >= 1 */ static const char *transa = "N"; static const double one = 1.0, zero = 0.0; size_t nSqr = n * ((size_t) n); double /* temporary matrix */ *tmp = (double *) R_alloc(nSqr, sizeof(double)); /* Take powers in multiples of 2 until there is only one * product left to make. That is, if k = 5, compute (x * x), * then ((x * x) * (x * x)) and finally ((x * x) * (x * x)) * x. */ Memcpy(z, x, nSqr); k--; while (k > 0) { if (k & 1) { /* z := z * x */ F77_CALL(dgemm)(transa, transa, &n, &n, &n, &one, z, &n, x, &n, &zero, tmp, &n FCONE FCONE); Memcpy(z, tmp, nSqr); } if(k == 1) break; k >>= 1; /* efficient division by 2; now have k >= 1 */ /* x := x * x */ F77_CALL(dgemm)(transa, transa, &n, &n, &n, &one, x, &n, x, &n, &zero, tmp, &n FCONE FCONE); Memcpy(x, tmp, nSqr); } } } expm/src/Makevars0000644000176200001440000000016610760034000013477 0ustar liggesusers# as for a -*- Makefile -*- we use the BLAS and the LAPACK library: PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) expm/src/R_dgebal.c0000644000176200001440000000454414531337476013701 0ustar liggesusers#include /* strlen(), toupper() .. */ #include "expm.h" static char ebal_type(const char *typstr) { char typup; if (strlen(typstr) != 1) error(_("argument type='%s' must be a character string of string length 1"), typstr); typup = toupper(*typstr); if (typup == '1') typup = 'O'; /* alias */ if (typup != 'N' && typup != 'P' && typup != 'S' && typup != 'B') error(_("argument type='%s' must be one of 'N', 'P', 'S', or 'B'"), typstr); return typup; } SEXP R_dgebal(SEXP x, SEXP type) { SEXP dims, z, Scale, i_1, i_2, ans, nms; char typnm[] = {'\0', '\0'}; // only the first is changed; 2nd = final \0 string terminator int n, info, nprot = 2; if (!isNumeric(x) || !isMatrix(x)) error(_("invalid 'x': not a numeric (classical R) matrix")); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; if (n != INTEGER(dims)[1]) error(_("non-square matrix")); typnm[0] = ebal_type(CHAR(asChar(type))); if (isInteger(x)) { nprot++; x = PROTECT(coerceVector(x, REALSXP)); } else if(n > 0 && typnm[0] == 'S') { /* FIXME: if 'x' contains +/- Inf dgebal() loops infinitely <==> LAPACK "bug" ----- fix in ..../R/src/modules/lapack/dlapack.f.~dgebal-Inf-patch~ But that does *not* help for external Lapack libraries */ double *dx = REAL(x), aMax = 0.; // aMax := max_{i,j} |x[i,j]| for(int i=0; i < n*n; i++) if(aMax < dx[i]) aMax = dx[i]; if(aMax == R_PosInf) error(_("R_dgebal(*, type=\"S\"): Infinite matrix entry")); } PROTECT(ans = allocVector(VECSXP, 4)); PROTECT(nms = allocVector(STRSXP, 4)); SET_STRING_ELT(nms, 0, mkChar("z")); SET_VECTOR_ELT(ans, 0, (z = duplicate(x))); /* permutation or scale array */ SET_STRING_ELT(nms, 1, mkChar("scale")); SET_VECTOR_ELT(ans, 1, (Scale = allocVector(REALSXP, n))); SET_STRING_ELT(nms, 2, mkChar("i1")); SET_VECTOR_ELT(ans, 2, (i_1 = allocVector(INTSXP, 1))); SET_STRING_ELT(nms, 3, mkChar("i2")); SET_VECTOR_ELT(ans, 3, (i_2 = allocVector(INTSXP, 1))); if(n > 0) { F77_CALL(dgebal)(typnm, &n, REAL(z), &n, INTEGER(i_1), INTEGER(i_2), REAL(Scale), &info FCONE); if (info) error(_("LAPACK's dgebal(%s) returned info code %d"), typnm, info); } setAttrib(ans, R_NamesSymbol, nms); /* now return list(z, scale[], i1, i2) */ UNPROTECT(nprot); return ans; } expm/src/R_NLS_locale.h0000644000176200001440000000023513444515240014421 0ustar liggesusers/* Localization */ #include #ifdef ENABLE_NLS #include #define _(String) dgettext ("expm", String) #else #define _(String) (String) #endif expm/src/matexp_MH09.c0000644000176200001440000001472313704012703014215 0ustar liggesusers/* Copyright (C) 2013-2014 Drew Schmidt. Copyright (C) 2014 Martin Maechler This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, see . */ /* Matrix exponentiation algorithm from: "New Scaling and Squaring Algorithm for the Matrix Exponential", by Awad H. Al-Mohy and Nicholas J. Higham, August 2009 */ #include // #include #include "expm.h" #define SGNEXP(x,pow) (x==0?(pow==0?1:0):(x>0?1:(pow%2==0?1:(-1)))) // -------------------------------------------------------- // Utilities // -------------------------------------------------------- // C = A * B for square matrices static void matprod(int n, double *A, double *B, double *C) { const double one = 1.0, zero = 0.0; F77_CALL(dgemm)("N", "N", &n, &n, &n, &one, A, &n, B, &n, &zero, C, &n FCONE FCONE); } // Copy A ONTO B, i.e. B = A static inline void matcopy(int n, double *A, double *B) { F77_CALL(dlacpy)("A", &n, &n, A, &n, B, &n FCONE); // uplo = ^ } /** Identity matrix * * @param n integer >= 1 * @param a n x n pre-allocated to contain the identity matrix */ static inline void mateye(const unsigned int n, double *a) { int i; for (i=0; i norm) norm = tmp; } return norm; } #define NTHETA 5 static int matexp_scale_factor(const double *x, const int n) { const double theta[] = {1.5e-2, 2.5e-1, 9.5e-1, 2.1e0, 5.4e0}; const double x_1 = matnorm_1(x, n); for (int i=0; i < NTHETA; i++) { if (x_1 <= theta[i]) return 0; } int i = (int) ceil(log2(x_1/theta[4])); return 1 << i; } // ___ MM: FIXME we have a matpow() already in ./matpow.c // --- Merge the two, keep the better one // Matrix power by squaring: P = A^b (A is garbage on exit) static void matpow_by_squaring(double *A, int n, int b, double *P) { if (b == 1) { matcopy(n, A, P); return; } mateye(n, P); // P := I if (b == 0) return; // General case: b >= 2 double *TMP = (double *) R_alloc(n*n, sizeof(double)); while (b) { if (b&1) { // P := P A matprod(n, P, A, TMP); matcopy(n, TMP, P); } b >>= 1; // A := A^2 : matprod(n, A, A, TMP); matcopy(n, TMP, A); } } // -------------------------------------------------------- // Matrix Exponentiation via Pade' Approximations // -------------------------------------------------------- const double matexp_pade_coefs[14] = { 1.0, 0.5, 0.12, 1.833333333333333333333e-2, 1.992753623188405797101e-3, 1.630434782608695652174e-4, 1.035196687370600414079e-5, 5.175983436853002070393e-7, 2.043151356652500817261e-8, 6.306022705717595115002e-10, 1.483770048404140027059e-11, 2.529153491597965955215e-13, 2.810170546219962172461e-15, 1.544049750670308885967e-17 }; /* r_m(x) = p_m(x) / q_m(x), where p_m(x) = sum_{j=0}^m (2m-j)!m!/(2m)!/(m-j)!/j! * x^j and q_m(x) = p_m(-x) */ // Workhorse for matexp_pade void matexp_pade_fillmats(const int m, const int n, const int i, double *N, double *D, double *B, double *C) { const double tmp = matexp_pade_coefs[i]; const int sgn = SGNEXP(-1, i); /* Performs the following actions: B = C N = pade_coef[i] * C D = (-1)^j * pade_coef[i] * C */ for (int j=0; j < m*n; j++) { double t_j = C[j]; B[j] = t_j; t_j *= tmp; N[j] += t_j; D[j] += sgn*t_j; } } /** * Exponentiation via Pade' expansion * * @param n * @param p * @param A * @param N */ static void matexp_pade(int n, const int p, double *A, double *N) { int i, info = 0, n2 = n*n; // FIXME: check n2 (or n, such that n2 did not overflow !) // Power of A double *B = (double*) R_alloc(n2, sizeof(double)); // Temporary storage for matrix multiplication; matcopy(n, A, C); double *C = Memcpy((double*)R_alloc(n2, sizeof(double)), A, n2); double *D = (double*) R_alloc(n2, sizeof(double)); for (i=0; i 1) matprod(n, A, B, C); // Update matrices matexp_pade_fillmats(n, n, i, N, D, B, C); } // R <- inverse(D) %*% N int *ipiv = (int *) R_alloc(n, sizeof(int)); /* assert(ipiv != NULL); */ F77_CALL(dgesv)(&n, &n, D, &n, ipiv, N, &n, &info); } // matexp_pade() /** * Matrix Exponential * * @param x Input (square) matrix. On exit, the values in x are "garbage"! * @param n Number of rows/cols of (square) matrix x. * @param p Order of the Pade' approximation. 0 < p <= 13. * @param ret On exit, ret = expm(x). */ void matexp_MH09(double *x, int n, const int p, double *ret) { int m = matexp_scale_factor(x, n); if (m == 0) { matexp_pade(n, p, x, ret); return; } int nn = n*n, one = 1; double tmp = 1. / ((double) m); F77_CALL(dscal)(&nn, &tmp, x, &one); matexp_pade(n, p, x, ret); matcopy(n, ret, x); matpow_by_squaring(x, n, m, ret); } // -------------------------------------------------------- // R Wrapper // -------------------------------------------------------- SEXP R_matexp_MH09(SEXP x, SEXP p) { const int n = nrows(x), n2 = n*n; SEXP R = PROTECT(allocMatrix(REALSXP, n, n)); SEXP x_ = duplicate(x); PROTECT_INDEX xpi; PROTECT_WITH_INDEX(x_, &xpi); if (!isReal(x)) /* coercion to numeric */ REPROTECT(x_ = coerceVector(x_, REALSXP), xpi); // MM{FIXME}: We have already duplicated x to x_ : this should *not* be needed: double *x_cp = Memcpy((double*)R_alloc(n2, sizeof(double)), REAL(x_), n2); matexp_MH09(x_cp, n, INTEGER(p)[0], REAL(R)); UNPROTECT(2); return R; } expm/src/expm-eigen.h0000644000176200001440000000035713704012703014223 0ustar liggesusers/* ===== File part of R package expm ===== * * expm-eigen.h * * Created by Christophe Dutang on 27/02/08. * */ #include "expm.h" SEXP do_expm_eigen(SEXP x, SEXP tolin); void expm_eigen(double *x, int n, double *z, double tol); expm/src/expm.c0000644000176200001440000002144313704012703013130 0ustar liggesusers/* ===== File part of R package expm ===== * * Function to compute the matrix exponential * * exp(M) = sum(n = 0:Inf; M^n / n!), * * where M is an (n x n) matrix. * * The functions therein use LAPACK and BLAS routines. Nicely * formatted man pages for these can be found at * * * * AUTHORS: Vincent Goulet , Christophe * Dutang, based on code in package Matrix. */ #include "expm.h" /* For matrix exponential calculations. Pade constants * * n_{pqj} = [(p + q - j)! p!]/[(p + q)! j! (p - j)!] * * and * * d_{pqj} = [(p + q - j)! q!]/[(p + q)! j! (q - j)!] * * for p = q = 8 and j = 1, ..., 8. */ const static double padec88 [] = { 5.0000000000000000e-1, 1.1666666666666667e-1, 1.6666666666666667e-2, 1.6025641025641026e-3, 1.0683760683760684e-4, 4.8562548562548563e-6, 1.3875013875013875e-7, 1.9270852604185938e-9, }; /* Matrix exponential exp(x), where x is an (n x n) matrix. Result z * is an (n x n) matrix. Mostly lifted from the core of fonction * expm() of package Matrix, which is itself based on the function of * the same name in Octave. */ void expm(double *x, int n, double *z, precond_type precond_kind) { if (n == 1) z[0] = exp(x[0]); /* scalar exponential */ else { /* Constants */ const double one = 1.0, zero = 0.0; const int i1 = 1, nsqr = n * n, np1 = n + 1; /* Variables */ int i, j, is_uppertri = TRUE;; int ilo, ihi, iloscal, ihiscal, info, sqrpowscal; double infnorm, trshift, m1pj = -1; /* Arrays */ int *pivot = (int *) R_alloc(n, sizeof(int)); /* pivot vector */ double *scale; /* scale array */ double *perm = (double *) R_alloc(n, sizeof(double));/* permutation/sc array */ double *work = (double *) R_alloc(nsqr, sizeof(double)); /* workspace array */ double *npp = (double *) R_alloc(nsqr, sizeof(double)); /* num. power Pade */ double *dpp = (double *) R_alloc(nsqr, sizeof(double)); /* denom. power Pade */ Memcpy(z, x, nsqr); /* Check if matrix x is upper triangular; stop checking as * soon as a non-zero value is found below the diagonal. */ for (i = 0; i < n - 1 && is_uppertri; i++) for (j = i + 1; j < n; j++) if (!(is_uppertri = x[i * n + j] == 0.0)) break; /* Step 1 of preconditioning: shift diagonal by average diagonal. */ trshift = 0.0; for (i = 0; i < n; i++) trshift += x[i * np1]; trshift /= n; /* average diagonal element */ if (trshift > 0.0) for (i = 0; i < n; i++) z[i * np1] -= trshift; /* Step 2 of preconditioning: balancing with dgebal. */ if(precond_kind == Ward_2 || precond_kind == Ward_buggy_octave) { if (is_uppertri) { /* no need to permute if x is upper triangular */ ilo = 1; ihi = n; } else { F77_CALL(dgebal)("P", &n, z, &n, &ilo, &ihi, perm, &info FCONE); if (info) error(_("LAPACK routine dgebal returned info code %d when permuting"), info); } scale = (double *) R_alloc(n, sizeof(double)); F77_CALL(dgebal)("S", &n, z, &n, &iloscal, &ihiscal, scale, &info FCONE); if (info) error(_("LAPACK routine dgebal returned info code %d when scaling"), info); } else if(precond_kind == Ward_1) { F77_CALL(dgebal)("B", &n, z, &n, &ilo, &ihi, perm, &info FCONE); if (info) error(_("LAPACK' dgebal(\"B\",.) returned info code %d"), info); } else { error(_("invalid 'precond_kind: %d"), precond_kind); } /* Step 3 of preconditioning: Scaling according to infinity * norm (a priori always needed). */ infnorm = F77_CALL(dlange)("I", &n, &n, z, &n, work FCONE); sqrpowscal = (infnorm > 0) ? imax2((int) 1 + log(infnorm)/M_LN2, 0) : 0; if (sqrpowscal > 0) { double scalefactor = R_pow_di(2, sqrpowscal); for (i = 0; i < nsqr; i++) z[i] /= scalefactor; } /* Pade approximation (p = q = 8): compute x^8, x^7, x^6, * ..., x^1 */ for (i = 0; i < nsqr; i++) { npp[i] = 0.0; dpp[i] = 0.0; } for (j = 7; j >= 0; j--) { /* npp = z * npp + padec88[j] * z */ F77_CALL(dgemm) ("N", "N", &n, &n, &n, &one, z, &n, npp, &n, &zero, work, &n FCONE FCONE); /* npp <- work + padec88[j] * z */ for (i = 0; i < nsqr; i++) npp[i] = work[i] + padec88[j] * z[i]; /* dpp = z * dpp + (-1)^j * padec88[j] * z */ F77_CALL(dgemm) ("N", "N", &n, &n, &n, &one, z, &n, dpp, &n, &zero, work, &n FCONE FCONE); for (i = 0; i < nsqr; i++) dpp[i] = work[i] + m1pj * padec88[j] * z[i]; m1pj *= -1; /* (-1)^j */ } /* power 0 */ for (i = 0; i < nsqr; i++) dpp[i] *= -1.0; for (j = 0; j < n; j++) { npp[j * np1] += 1.0; dpp[j * np1] += 1.0; } /* Pade approximation is (dpp)^-1 * npp. */ F77_CALL(dgetrf) (&n, &n, dpp, &n, pivot, &info); if (info) error(_("LAPACK routine dgetrf returned info code %d"), info); F77_CALL(dgetrs) ("N", &n, &n, dpp, &n, pivot, npp, &n, &info FCONE); if (info) error(_("LAPACK routine dgetrs returned info code %d"), info); Memcpy(z, npp, nsqr); /* Now undo all of the preconditioning */ /* Preconditioning 3: square the result for every power of 2 */ while (sqrpowscal--) { F77_CALL(dgemm)("N", "N", &n, &n, &n, &one, z, &n, z, &n, &zero, work, &n FCONE FCONE); Memcpy(z, work, nsqr); } /* Preconditioning 2: Inversion of 'dgebal()' : * ------------------ Note that dgebak() seems *not* applicable */ /* Step 2 a) apply inverse scaling */ if(precond_kind == Ward_2 || precond_kind == Ward_buggy_octave) { for (j = 0; j < n; j++) for (i = 0; i < n; i++) z[i + j * n] *= scale[i]/scale[j]; } else if(precond_kind == Ward_1) { /* here, perm[ilo:ihi] contains scale[] */ for (j = 0; j < n; j++) { double sj = ((ilo-1 <= j && j < ihi)? perm[j] : 1.); for (i = 0; i < ilo-1; i++) z[i + j * n] /= sj; for (i = ilo-1; i < ihi; i++) z[i + j * n] *= perm[i]/sj; for (i = ihi+1; i < n; i++) z[i + j * n] /= sj; } } /* 2 b) Inverse permutation (if not the identity permutation) */ if (ilo != 1 || ihi != n) { if(precond_kind == Ward_buggy_octave) { /* inverse permutation vector */ int *invP = (int *) R_alloc(n, sizeof(int)); /* balancing permutation vector */ for (i = 0; i < n; i++) invP[i] = i; /* identity permutation */ /* leading permutations applied in forward order */ for (i = 0; i < (ilo - 1); i++) { int p_i = (int) (perm[i]) - 1; int tmp = invP[i]; invP[i] = invP[p_i]; invP[p_i] = tmp; } /* trailing permutations applied in reverse order */ for (i = n - 1; i >= ihi; i--) { int p_i = (int) (perm[i]) - 1; int tmp = invP[i]; invP[i] = invP[p_i]; invP[p_i] = tmp; } /* construct inverse balancing permutation vector */ Memcpy(pivot, invP, n); for (i = 0; i < n; i++) invP[pivot[i]] = i; /* apply inverse permutation */ Memcpy(work, z, nsqr); for (j = 0; j < n; j++) for (i = 0; i < n; i++) z[i + j * n] = work[invP[i] + invP[j] * n]; } else if(precond_kind == Ward_2 || precond_kind == Ward_1) { /* ---- new code by Martin Maechler ----- */ #define SWAP_ROW(I,J) F77_CALL(dswap)(&n, &z[(I)], &n, &z[(J)], &n) #define SWAP_COL(I,J) F77_CALL(dswap)(&n, &z[(I)*n], &i1, &z[(J)*n], &i1) #define RE_PERMUTE(I) \ int p_I = (int) (perm[I]) - 1; \ SWAP_COL(I, p_I); \ SWAP_ROW(I, p_I) /* reversion of "leading permutations" : in reverse order */ for (i = (ilo - 1) - 1; i >= 0; i--) { RE_PERMUTE(i); } /* reversion of "trailing permutations" : applied in forward order */ for (i = (ihi + 1) - 1; i < n; i++) { RE_PERMUTE(i); } } /* else if(precond_kind == Ward_1) { */ /* } */ } /* Preconditioning 1: Trace normalization */ if (trshift > 0) { double mult = exp(trshift); for (i = 0; i < nsqr; i++) z[i] *= mult; } } } /* Main function, the only one used by .External(). */ SEXP do_expm(SEXP x, SEXP kind) { SEXP dims, z; int n, nprot = 0; double *rx, *rz; const char *ch_kind = CHAR(asChar(kind)); precond_type PC_kind = Ward_2 /* -Wall */; if (!isNumeric(x) || !isMatrix(x)) error(_("invalid argument: not a numeric matrix")); if (isInteger(x)) { x = PROTECT(coerceVector(x, REALSXP)); nprot++; } rx = REAL(x); if(!strcmp(ch_kind, "Ward77")) { PC_kind = Ward_2; } else if(!strcmp(ch_kind, "buggy_Ward77")) { PC_kind = Ward_buggy_octave; } else if(!strcmp(ch_kind, "Ward77_1")) { PC_kind = Ward_1; } else error(_("invalid 'kind' argument: %s\n"), ch_kind); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; if (n != INTEGER(dims)[1]) error(_("non-square matrix")); if (n == 0) { UNPROTECT(nprot); return(allocMatrix(REALSXP, 0, 0)); } PROTECT(z = allocMatrix(REALSXP, n, n)); nprot++; rz = REAL(z); expm(rx, n, rz, PC_kind); /* ---- */ setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(nprot); return z; } expm/src/logm-eigen.c0000644000176200001440000001770513704012703014210 0ustar liggesusers/* ===== File part of R package expm ===== * * Function to compute the matrix logarithm * * log(M) = L such that * * M = exp(L) where * * exp(L) = sum(n = 0:Inf; L^n / n!), * * where M and L are an (n x n) matrix. * * The functions therein use LAPACK and BLAS routines. Nicely * formatted man pages for these can be found at * * * * AUTHORS: Christophe Dutang, based on code eigen, * * i.e., function 'modLa_rg' and 'modLa_dgesv' in R's * /src/modules/lapack/lapack.c, used in eigen() */ #include "logm-eigen.h" void logm_eigen(double *x, int n, double *z, double tol) { if (n == 1) z[0] = log(x[0]); /* scalar logarithm */ else { const int nsqr = n * n; const Rcomplex cone = {1., 0.}, czero = {0., 0.}; int i, j; int info, lwork, is_conjug, is_diag; double onenorm, rcond, tmp; /* Arrays */ int *ipiv = (int *) R_alloc(n, sizeof(int)); /* permutation vector */ double *left, *right, *workdiag; /* left and right eigenvectors and workspace for diagonalisation */ double *wR = (double *) R_alloc(n, sizeof(double)); /* real part of eigenvalues */ double *wI = (double *) R_alloc(n, sizeof(double)); /* imaginary part of eigenvalues */ double *rworksing = (double *) R_alloc(2*n, sizeof(double)); /* working vector to test the singularity */ Rcomplex *eigvect = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* (right) eigenvectors matrix */ Rcomplex *eigvectinv = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* its inverse */ Rcomplex *logeigval; /* complex matrix diag(log(eigenvalues)) */ Rcomplex *ctmp = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* temp working variable */ Rcomplex *worksing = (Rcomplex *) R_alloc(2*n, sizeof(Rcomplex)); /* workspace to test the singularity */ Memcpy(z, x, nsqr); /* Test if x is diagonalisable by computing its eigenvalues and (right) eigenvectors */ /* code based on modLa_rg in lapack.c, used in eigen.R */ left = (double *) 0; right = (double *) R_alloc(nsqr, sizeof(double)); /* 1 - ask for optimal size of work array */ lwork = -1; F77_CALL(dgeev)("N", "V", &n, z, &n, wR, wI, left, &n, right, &n, &tmp, &lwork, &info FCONE FCONE); if (info != 0) error(_("error code %d from Lapack routine dgeev"), info); lwork = (int) tmp; workdiag = (double *) R_alloc(lwork, sizeof(double)); /* 2 - compute eigenvalues and (right) eigenvectors */ F77_CALL(dgeev)("N", "V", &n, z, &n, wR, wI, left, &n, right, &n, workdiag, &lwork, &info FCONE FCONE); if (info != 0) error(_("error code %d from Lapack routine dgeev"), info); /* try to invert the eigenvectors matrix */ /* 1 - build the Rcomplex matrix with eigenvectors */ for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { is_conjug = 0; if(i < n-1) { /* conjugate eigenvalues */ if(wR[i] == wR[i+1] && wI[i] == -wI[i+1] && wI[i] != 0.0) { is_conjug = 1; eigvect[i * n + j].r = right[i * n + j]; eigvect[i * n + j].i = right[(i+1) * n + j]; } } if(i > 0) { /* conjugate eigenvalues */ if(wR[i] == wR[i-1] && wI[i] == -wI[i-1] && wI[i] != 0.0) { is_conjug = 1; eigvect[i * n + j].r = right[(i-1) * n + j]; eigvect[i * n + j].i = -right[i * n + j]; } } /* real eigenvalues */ if(!is_conjug) { eigvect[i * n + j].r = right[i * n + j]; eigvect[i * n + j].i = 0.0; } /* eigvectinv initialise with the identity matrix */ eigvectinv[i * n +j].r = (i == j) ? 1.0 : 0.0; eigvectinv[i * n +j].i = 0.0; } } /* 2 - store the matrix eigvect (because function zgesv will change it) */ Memcpy(ctmp, eigvect, nsqr); /* 3 - solve a linear complex equation system with eigvectinv equals * to matrix identity. hence, on exit eigvectinv contains the * inverse of complex matrix eigvect. code base on solve.R */ F77_CALL(zgesv)(&n, &n, eigvect, &n, ipiv, eigvectinv, &n, &info); if (info > 0) is_diag = 0; //matrix eigvect is exactly singular. if (info < 0) error(_("argument %d of Lapack routine dgesv had invalid value"), -info); if (info == 0) is_diag = 1; /* check if matrix eigvectinv is numerically singular */ if (is_diag) { /* compute the reciprocal condition number of eigvectinv. */ /* 1 - compute the one norm of the matrix eigvectinv */ onenorm = F77_CALL(zlange)("1", &n, &n, eigvectinv, &n, (double*) NULL FCONE); /* 2 - estimates the reciprocal of the condition number * when the one norm is used. */ F77_CALL(zgecon)("1", &n, eigvectinv, &n, &onenorm, &rcond, worksing, rworksing, &info FCONE); if (rcond < tol) is_diag=0; } if (is_diag) { /* x is diagonalisable so * compute complex matrix operations : * eigvect %*% diag(log(eigenvalues)) %*% eigvectinv */ /* 1 - logeigval is the complex matrix diag(log(eigenvalues)) */ /* code based on z_log in complex.c */ logeigval = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { if(i == j) { logeigval[i * n +j].r = log( sqrt(wR[i] * wR[i] + wI[i] * wI[i]) ) ; logeigval[i * n +j].i = atan2( wI[i], wR[i] ) ; } else { logeigval[i * n +j].r = 0.0; logeigval[i * n +j].i = 0.0; } } } /* 2 - restore the matrix eigvect */ Memcpy(eigvect, ctmp, nsqr); /* 3 - compute (complex) matrix product: ctmp <- eigvect * logeigval */ F77_CALL(zgemm)("N", "N", &n, &n, &n, &cone, eigvect, &n, logeigval, &n, &czero, ctmp, &n FCONE FCONE); /* 4 - compute (complex) matrix product: logeigval <- ctmp * eigvectinv */ F77_CALL(zgemm)("N", "N", &n, &n, &n, &cone, ctmp, &n, eigvectinv, &n, &czero, logeigval, &n FCONE FCONE); //TOCHECK /* store the real part in z */ /* the matrix logarithm is always real, * even if x has complex eigen values. */ for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { z[i * n + j] = logeigval[i * n + j].r; // Rprintf(" %f \t", logeigval[i * n + j].i); } } } else error("non diagonalisable matrix"); } } /* Main function, the only one used by .Call(). */ SEXP do_logm_eigen(SEXP x, SEXP tolin) { SEXP dims, z; int n, m; double *rx = REAL(x), *rz; double tol = asReal(tolin); if (!isNumeric(x) || !isMatrix(x)) error(_("invalid argument")); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; m = INTEGER(dims)[0]; if (n != m) error(_("non-square matrix")); if (n == 0) return(allocVector(REALSXP, 0)); PROTECT(z = allocMatrix(REALSXP, n, n)); rz = REAL(z); logm_eigen(rx, n, rz, tol); setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(1); return z; } expm/src/matrexp.f0000644000176200001440000002206312470350137013646 0ustar liggesuserscccc-*- mode: fortran; kept-old-versions: 12; kept-new-versions: 20; -*- c This program computes exp(A) for a given matrix A. c c 2 algorithms are employed: c 1. The Taylor expansion of order "ntaylor," denoted by T(ntaylor). c 2. The Pade diagonal approximation of order c "npade" denoted by P(npade), is used instead, IFF ntaylor = 0 c The algorithm is applied twice to calculate c T(ntaylor) and T(ntaylor+10) [or, when ntaylor=0, c to calculate P(npade) and P(npade+10)]. c An upper bound for the L2 norm of the Cauchy error c T(ntaylor+10)-T(ntaylor) [or, when ntaylor=0, c P(npade+10)-P(npade)] is computed. c The result exp(A) is returned via the first argument. c c This version works with R (i.e., is written as a subroutine) c c To use it, first do c % R SHLIB matrexp.f c to make the shared library matrexp.so c c and then in R, c > dyn.load("matrexp.so") c > .C("matrexp_",as.double(runif(9)), c as.integer(3),as.integer(0),as.integer(8)) c c (This is all done automatically in the R package 'expm'.) c subroutine matrexp(a, n, ntaylor, npade, accuracy) integer n, ntaylor, npade double precision a(n,n), accuracy c "n" is the order of the given matrix A c double precision sum(n,n), sol10(n,n) double precision dsqrt, dl1norm, dlinfnorm integer log2 integer npower, i,j c FIXME: consider computing c sqrt(dl1norm(n,a) * dlinfnorm(n,a)) c in one function -- no need for the two separate l*norm() functions c npower= log2(dsqrt(dl1norm(n,a)*dlinfnorm(n,a))) + 4 c c Use the algorithm to compute T(ntaylor) or P(npade) c if(ntaylor.gt.0)then call taylor(n,ntaylor,npower,a,sum) else call pade(n,npade,npower,a,sum) endif c c computing the "solution" T(ntaylor+10) or P(npade+10) c if(ntaylor.gt.0) then call taylor(n,ntaylor+10,npower,a,sol10) else call pade(n,npade+10,npower,a,sol10) endif call powMat(n,sum, npower) c copy the result back into a c do i=1,n do j=1,n a(i,j) = sum(i,j) end do end do call powMat(n,sol10, npower) c c compute the Cauchy error T(ntaylor+10)- T(ntaylor) c or P(npade+10) - P(npade) c cc- BLAS: daxpy(m, alpha, x, 1, y, 1) : y := y + alpha*x c call subtract(n,sum,sol10, sum) accuracy = dsqrt(dl1norm(n,sum) * dlinfnorm(n,sum)) return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine taylor(m,ntaylor,npower,a,sum) c Taylor series for exp(a/2**npower) integer m, ntaylor, npower double precision a(m,m),sum(m,m) double precision T(m,m) integer nscale,n nscale=2**npower c print*,'A is scaled by 2**',npower,' =',nscale call identity(m, sum) do n=ntaylor,1,-1 C FIXME: use multScalAdd() instead of these three C ----- add tests for this taylor code !! --> ../tests/ex. call multiplymatrix(m,sum,a,T) call multiplyscalar(m,T,1.d0/dble(n*nscale),sum) call addtodiag(m,sum,1.d0) C --------- 1) multiplymatrix(., A,. B,. C) ; 2) multiplyscalar(., C, s, D) C 3) addtodiag (D, ., 1.0) C ---> D := s (A B) + Id() ---> do this directly via DGEMM : C D := Id() ; D := s * A B + 1 * D C__ almost: call multScalAdd(m, 1.d0/dble(n*nscale), sum,a, T) c NOTE: result must be 'sum' enddo return end subroutine pade(m,npade,npower,a,approx) c Pade approximation for exp(a/2**npower) integer m, npade, npower double precision a(m,m), approx(m,m) c Var double precision aminus(m,m),T(m,m) double precision padenom(m,m),padedenom(m,m) integer nscale,n,i nscale=2**npower c print*,'A is scaled by 2**',npower,' =',nscale call identity(m,padenom) call identity(m,padedenom) do n=npade,1,-1 call multiplymatrix(m,padenom,a,T) call multiplyscalar(m,T, $ dble(npade-n+1)/dble(n*(2*npade-n+1)*nscale),padenom) call addtodiag(m,padenom,1.d0) enddo call minus(m,a,aminus) do n=npade,1,-1 call multiplymatrix(m,padedenom,aminus,T) call multiplyscalar(m,T, $ dble(npade-n+1)/dble(n*(2*npade-n+1)*nscale),padedenom) call addtodiag(m,padedenom,1.d0) enddo do i=1,m call solve(m,padedenom,padenom(1,i),approx(1,i)) end do return end c MM: FIXME: Use BLAS for the following !!! c ----- (also R internal things --> use C, not Fortran ! c initializing an identity matrix subroutine identity(m,x) integer m double precision x(m,m) integer i,j do i=1,m do j=1,m x(i,j)= 0d0 enddo x(i,i)= 1d0 enddo return end C-- NOTA BENE: We also have C --------- 1) multiplymatrix(., A,. B,. C) ; 2) multiplyscalar(., C, s, D) C 3) addtodiag (D, ., 1.0) C ---> D := s (A B) + Id() ---> do this directly via DGEMM : C D := Id() ; D := s * A B + 1 * D subroutine multScalAdd(m,s, x,y,z) integer m double precision x(m,m),y(m,m),z(m,m), s c GEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC ) c C := alpha * AB + beta * C call identity(m, z) call dgemm('N','N', m,m,m, s, x, m, y, m, 1.d0, z, m) return end c DSCAL ( N, ALPHA, X, 1) : x <- alpha * x (x = x[1:n]) c FIXME: replace by using DSCAL : subroutine multiplyscalar(m,x,s,y) c multiplying a matrix x by a scalar s Y := s X integer m double precision x(m,m),y(m,m), s integer i,j do i=1,m do j=1,m y(i,j)=x(i,j)*s enddo enddo return end c DGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC ) c C := alpha A B + beta C subroutine multiplymatrix(m,x,y,z) c multiplying two m x m matrices Z := X %*% Y integer m double precision x(m,m),y(m,m),z(m,m) c GEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC ) c C := a * AB + b * C call dgemm('N','N', m,m,m, 1.d0, x, m, y, m, 0.d0, z, m) return end subroutine powMat(m,x,ipower) c Compute x ^ (2^i) -- by simple squaring integer m, ipower double precision x(m,m) double precision xx(m,m) integer i, m2 m2 = m*m call dcopy(m2, x,1, xx,1) do i=1,ipower call multiplymatrix(m,xx,xx,x) if(i .lt. ipower) call dcopy(m2, x,1, xx,1) enddo return end cc-- BLAS: daxpy(m, alpha, x, 1, y, 1) : y := y + alpha*x C this is now in mexp-common.f -- FIXME: use daxpy() or ... c c subroutine comb(m, x,a,y, z) c ---- c linear combination of 2 vectors z[] := x[] + a* y[] C BLAS DDOT ( N, X, INCX, Y, INCY ) --- inner product X' Y subroutine solve(m,A,f,x) c CGS iteration integer m double precision A(m,m), f(m), x(m) c double precision save(m),rcgs(m),r(m) double precision p(m),u(m) double precision rbar(m),v(m),q(m) external dnrm2, ddot double precision dnrm2, ddot double precision alpha, beta, thresh, eps, eta, omega0,omega1, + omegainit, rho0,rho1, scalar,sigma, tau,vv integer l thresh=1.d-100 eps=1.d-30 call zero(m,x) call dcopy(m, f,1, r, 1) call dcopy(m, r,1, rcgs,1) call dcopy(m, r,1, p, 1) call dcopy(m, r,1, u, 1) omega0= dnrm2(m,rcgs, 1) omegainit=omega0 c print*,'res0=',dabs(omegainit) tau=omega0 vv=0.d0 eta=0.d0 call dcopy(m, r,1, rbar,1) rho0= ddot(m, rbar,1, r,1) if(dabs(rho0).le.thresh)then c print*,'rho0=',rho0,' MG iteration number=1' return endif do 10 l=1,m call multiplyvector(m,A,p,v) sigma=ddot(m, rbar,1, v,1) if(dabs(sigma).le.thresh)then c print*,'sigma=',sigma,' iteration number=',2*l+1 return endif alpha=rho0/sigma if(dabs(alpha).le.thresh)then c print*,'alpha=',alpha,' iteration number=',2*l+1 return endif scalar=-alpha call comb(m,u,scalar,v,q) call add(m,u,q,v) call multiplyvector(m,A,v,save) call comb(m,rcgs,scalar,save,rcgs) omega1=dnrm2(m,rcgs, 1) call comb(m,x,alpha,v,x) c print*,'residual=',dabs(omega1),' iteration number=',2*l+1 if(dabs(omega1/omegainit).le.eps)then c print*,'iteration number=',2*l+1 return endif omega0=omega1 rho1=ddot(m, rbar,1, rcgs,1) if(dabs(rho1).le.thresh)then c print*,'rho1=',rho1,' iteration number=',2*l+1 return endif beta=rho1/rho0 rho0=rho1 c u[] := rcgs[] + beta q[] call comb(m,rcgs,beta,q,u) c save[] := q[] + beta p[] call comb(m,q,beta,p,save) c p[] := u[] + beta save[] = (rcgs[] + beta q[]) + beta(q[] + beta p[]) call comb(m,u,beta,save,p) c print*,'iteration number=',2*l+1 10 continue return end expm/src/logm-eigen.h0000644000176200001440000000035713704012703014210 0ustar liggesusers/* ===== File part of R package expm ===== * * logm-eigen.h * * Created by Christophe Dutang on 13/05/08. * */ #include "expm.h" SEXP do_logm_eigen(SEXP x, SEXP tolin); void logm_eigen(double *x, int n, double *z, double tol); expm/vignettes/0000755000176200001440000000000014547731256013251 5ustar liggesusersexpm/vignettes/expm.bib0000644000176200001440000000352412165310624014666 0ustar liggesusers@Article{Ward:77, author = {Ward, R. C.}, title = {Numerical Computation of the Matrix Exponential With Accuracy Estimate}, journal = {{SIAM} Journal on Numerical Analysis}, year = 1977, volume = 14, pages = {600-610} } @Article{MolerVanLoan:78, author = {Moler, C. and Van~{L}oan, C.}, title = {Nineteen dubious ways to compute the exponential of a matrix}, journal = {{SIAM} Review}, year = 1978, volume = 20, pages = {801-836} } @Manual{Matrix-pkg, title = {Matrix: A Matrix package for R}, author = {Douglas Bates and Martin Maechler}, year = {2010}, note = {R package version 0.999375-38}, language = {english} } @Book{octave, author = {Eaton, J. W.}, title = {{GNU} Octave Manual}, publisher = {Network Theory Limited}, year = 2002, ISBN = {0-9541617-2-6}, url = {http://www.octave.org}, language = {english} } @Book{Higham:2008, author = {Higham, N.~J.}, year = 2008, title = {Functions of Matrices: Theory and Computation}, publisher = {Society for Industrial and Applied Mathematics}, address = {Philadelphia, PA, USA} } @comment{This is *LATER* than Higham(2008) - and *NOT* yet implemented in expm:} @article{Al-mohy_Higham:2009, author = {Awad H. Al-Mohy and Nicholas J. Higham}, year = 2009, title = {A New Scaling and Squaring Algorithm for the Matrix Exponential}, journal = {SIAM Journal on Matrix Analysis and Applications}, volume = 31, number = 3, pages = {970-989}, publisher = {SIAM}, keywords = {matrix exponential; matrix function; scaling and squaring method; Pade approximation; backward error analysis; matrix norm estimation; overscaling; MATLAB; expm}, url = {http://link.aip.org/link/?SML/31/970/1}, doi = {10.1137/09074721X} } expm/vignettes/expm.Rnw0000644000176200001440000001052212165310624014674 0ustar liggesusers\documentclass{article} \usepackage{amsmath,url} \usepackage[round]{natbib} \usepackage[T1]{fontenc} \usepackage[english]{babel} %\usepackage{lucidabr} \usepackage[noae]{Sweave} %\VignetteIndexEntry{Using expm in packages} %\VignettePackage{expm} \title{Using \pkg{expm} in packages} \author{Christophe Dutang \\ ENSIMAG, Grenoble INP \\[3ex] Vincent Goulet \\ \'Ecole d'actuariat, Universit\'e Laval} \date{Jan. 2008 \ {\footnotesize (added note in June 2010)}} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\proglang}[1]{\textsf{#1}} \newcommand{\pkg}[1]{\textbf{#1}} \newcommand{\mat}[1]{\mathbf{#1}} \bibliographystyle{plainnat} \begin{document} \maketitle \section{Introduction} The \pkg{expm} package provides an \proglang{R} function \code{expm} to compute the matrix exponential of a real, square matrix. The matrix exponential of a matrix $\mat{A}$ is defined as \begin{align*} e^{\mat{A}} &= \mat{I} + \mat{A} + \frac{\mat{A}^2}{2!} + \dots \\ &= \sum_{k = 0}^\infty \frac{\mat{A}^k}{k!}. \end{align*} The actual computations are done in \proglang{C} by a function of the same name that is callable by other packages. Therefore, package authors can use these functions and avoid duplication of efforts. \section{Description of the functions} The \proglang{R} function \texttt{expm} takes as argument a real, square matrix and returns its exponential. Dimension names are preserved: <>= library(expm) m <- matrix(c(4, 1, 1, 2, 4, 1, 0, 1, 4), 3, 3) expm(m) dimnames(m) <- list(letters[1:3], LETTERS[1:3]) m expm(m) @ \bigskip %% manual centerig of "overlapping" box \hspace*{-.12\textwidth}% .08 = .16 / 2 \fbox{\begin{minipage}{1.16\textwidth}%% wider than the text! Note that the remainder of this text \textbf{mainly} relates to \code{expm(., method = "Ward77")}, i.e., the method of \cite{Ward:77} which is no longer the default method, as e.g., \code{method = "Higham08"} has found to be (``uniformly'') superior, see \cite{Higham:2008}. \end{minipage}} \bigskip The actual computational work is done in \proglang{C} by a routine defined as \begin{verbatim} void expm(double *x, int n, double *z) \end{verbatim} where \code{x} is the vector underlying the \proglang{R} matrix and \code{n} is the number of lines (or columns) of the matrix. The matrix exponential is returned in \code{z}. The routine uses the algorithm of \cite{Ward:77} based on diagonal Pad\'e table approximations in conjunction with three step preconditioning. The Pad\'e approximation to $e^{\mat{A}}$ is \begin{displaymath} e^{\mat{A}} \approx R(\mat{A}), \end{displaymath} with \begin{align*} R_{pq} (\mat{A}) &= (D_{pq}(\mat{A}))^{-1} N_{pq}(\mat{A}) \\ \intertext{where} D_{pq}(\mat{A}) &= \sum_{j=1}^p \frac{(p+q-j)! p!}{ (p+q)!j!(p-j)!}\, \mat{A}^j \\ \intertext{and} N_{pq}(\mat{A}) &= \sum_{j=1}^q \frac{(p+q-j)! q!}{ (p+q)!j!(q-j)!}\, \mat{A}^j. \end{align*} See \cite{MolerVanLoan:78} for an exhaustive treatment of the subject. The \proglang{C} routine is based on a translation made by \cite{Matrix} of the implementation of the corresponding Octave function \citep{octave}. \section{Calling the functions from other packages} Package authors can use facilities from \pkg{expm} in two (possibly simultaneous) ways: \begin{enumerate} \item call the \proglang{R} level function \code{expm} in \proglang{R} code; \item if matrix exponential calculations are needed in \proglang{C}, call the routine \code{expm}. \end{enumerate} Using \proglang{R} level function \code{expm} in a package simply requires the following two import directives: \begin{verbatim} Imports: expm \end{verbatim} in file \code{DESCRIPTION} and \begin{verbatim} import(expm) \end{verbatim} in file \code{NAMESPACE}. Accessing the \proglang{C} level routine further requires to prototype \code{expm} and to retrieve its pointer in the package initialization function \code{R\_init\_\textit{pkg}}, where \code{\textit{pkg}} is the name of the package: \begin{verbatim} void (*expm)(double *x, int n, double *z); void R_init_pkg(DllInfo *dll) { expm = (void (*) (double, int, double)) \ R_GetCCallable("expm", "expm"); } \end{verbatim} The definitive reference for these matters remains the \emph{Writing R Extensions} manual. \bibliography{expm} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% coding: utf-8 %%% End: expm/R/0000755000176200001440000000000014547731235011437 5ustar liggesusersexpm/R/logm.R0000644000176200001440000000133614107534174012516 0ustar liggesusers### ===== File part of R package expm ===== ### ### Function to compute the matrix logarithm ### logm <- function(x, method = c("Higham08", "Eigen"), ## order = 8, trySym = TRUE, tol = .Machine$double.eps) { ## work with "Matrix" too: A<-as.matrix(A) d <- dim(x) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "x"), domain=NA) method <- match.arg(method) switch(method, "Higham08" = logm.Higham08(x) , "Eigen" = { ## AUTHOR: Christophe Dutang ## matrix exponential using eigenvalues / spectral decomposition and ## Ward(1977) algorithm if x is numerically non diagonalisable .Call(do_logm_eigen, x, tol) }) } expm/R/matpow.R0000644000176200001440000000016610772074007013065 0ustar liggesusers### M^k for a matrix M and non-negative integer 'k' "%^%" <- function(x, k) .Call(R_matpow, x, as.integer(k)) expm/R/expm_vec.R0000644000176200001440000001100012404606717013354 0ustar liggesusers#### Originally by Roger B. Sidje (rbs@maths.uq.edu.au) #### EXPOKIT: Software Package for Computing Matrix Exponentials. #### ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 ##' Performs exp(A t) %*% v directly w/o evaluating exp(A) ##' Originally by Roger B. Sidje ##' EXPOKIT: Software Package for Computing Matrix Exponentials. ##' ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 ##' @title Compute exp(A t) %*% v directly ##' @param A n x n matrix ##' @param v n - vector ##' @param t number (scalar) ___ FIXME allow vector ? ___ ##' @param tol ##' @param btol ##' @param m.max integer constants you should only change if you know what you're doing ##' @param mxrej ##' @param verbose flag indicating if the algorithm should be verbose.. ##' @return a list with components ##' @author Ravi Varadhan, Johns Hopkins University; Martin Maechler (cosmetic) expAtv <- function(A, v, t=1, method = "Sidje98", ## currently only one method, with these arguments: ## FIXME argMeth=list( ... ) rescaleBelow = 1e-6, tol=1e-7, btol = 1e-7, m.max = 30, mxrej = 10, verbose = getOption("verbose")) { ## R translation: Ravi Varadhan, Johns Hopkins University ## "cosmetic", apply to sparse A: Martin Maechler, ETH Zurich if(length(d <- dim(A)) != 2) stop("'A' is not a matrix") # <- also for sparseMatrix stopifnot(length(v) == (n <- d[1]), m.max >= 2) if(n <= 1) { if(n == 1) return(list(eAtv = exp(A*t)*v, error = 0, nstep = 0L, n.reject = 0L)) stop("nrow(A) must be >= 1") } method <- match.arg(method) m <- min(n, m.max)# >= 2 ##- these are function arguments as well : gamma <- 0.9 delta <- 1.2 ##- nA <- norm(A, "I") if(nA < rescaleBelow) { ## rescaling, by MMaechler, needed for small norms A <- A/nA t <- t*nA nA <- 1 } rndoff <- nA * .Machine$double.eps t_1 <- abs(t) sgn <- sign(t) t_now <- 0 s_error <- 0 k1 <- 2 mb <- m xm <- 1/m beta <- sqrt(sum(v*v))# = norm(v) = |\ v || if(beta == 0) ## border case: v is all 0, and the result is too return(list(eAtv = v, error = 0L, nstep = 0L, n.reject = 0L)) fact <- (((m+1)/exp(1))^(m+1))*sqrt(2*pi*(m+1)) myRound <- function(tt) { s <- 10^(floor(log10(tt)) - 1) ceiling(tt/s)*s } t_new <- myRound( (1/nA)*(fact*tol/(4*beta*nA))^xm ) V <- matrix(0, n, m+1) H <- matrix(0, m+2, m+2) nstep <- n.rej <- 0L w <- v while (t_now < t_1) { nstep <- nstep + 1L t_step <- min(t_1 - t_now, t_new) if(verbose) cat(sprintf("while(t_now = %g < ..): nstep=%d, t_step=%g\n", t_now, nstep, t_step)) V[,1] <- (1/beta)*w for (j in 1:m) { p <- as.vector(A %*% V[,j]) for (i in 1:j) { H[i,j] <- s <- sum(V[,i] * p) p <- p - s * V[,i] } s <- sqrt(sum(p*p)) if (s < btol) { k1 <- 0 mb <- j t_step <- t_1 - t_now break } H[j+1, j] <- s V[, j+1] <- p / s } ## j-loop complete if (k1 != 0) { H[m+2, m+1] <- 1 av <- A %*% V[, m+1] avnorm <- sqrt(sum(av * av)) } i.rej <- 0L while (i.rej <= mxrej) { mx <- mb + k1; imx <- seq_len(mx) # = 1:mx if(verbose) cat(sprintf(" inner while: k1=%d -> mx=%d\n", k1, mx)) F <- expm(sgn * t_step * H[imx,imx, drop=FALSE]) if (k1 == 0) { err_loc <- btol break } else { phi1 <- abs(beta * F[m+1,1]) phi2 <- abs(beta * F[m+2,1] * avnorm) if(is.nan(phi1) || is.nan(phi2)) stop("NaN phi values; probably overflow in expm()") if (phi1 > 10*phi2) { err_loc <- phi2 xm <- 1/m } else if (phi1 > phi2) { err_loc <- (phi1 * phi2)/(phi1 - phi2) xm <- 1/m } else { err_loc <- phi1 xm <- 1/(m-1) } } if (err_loc <= delta * t_step*tol) break else { if (i.rej == mxrej) stop(gettextf('The requested tolerance (tol=%g) is too small for mxrej=%d.', tol, mxrej)) t_step <- gamma * t_step * (t_step * tol / err_loc)^xm s <- 10^(floor(log10(t_step))-1) t_step <- s * ceiling(t_step / s) i.rej <- i.rej + 1L } }## end{ while (i.rej < mx..) } n.rej <- n.rej + i.rej mx <- mb + max(0, k1-1); imx <- seq_len(mx) # = 1:mx w <- as.vector(V[, imx] %*% (beta*F[imx,1, drop=FALSE])) beta <- sqrt(sum(w*w)) t_now <- t_now + t_step t_new <- myRound(gamma * t_step * (t_step*tol/err_loc)^xm) err_loc <- max(err_loc, rndoff) s_error <- s_error + err_loc }# end{ while } list(eAtv = w, error = s_error, nstep = nstep, n.reject = n.rej) } expm/R/expmCond-all.R0000644000176200001440000003323014107534174014101 0ustar liggesusers#### -------------------*- mode: R; kept-new-versions: 25; kept-old-versions: 20 -*- #### Exponential Condition Number #### --------------------- #### Compute the Exponential Condition Number #### ("1" and Frobenius-Norm) "exactly" and approximately. #### #### All algorithms are based on the Fréchet derivative, #### i.e., the expmCond() functions call expmFrechet() #### for the calculation of the Fréchet derivative. expmCond <- function(A, method = c("1.est", "F.est", "exact"), expm = TRUE, abstol = 0.1, reltol = 1e-6, give.exact = c("both", "1.norm", "F.norm")) { ## Input: A; nxn Matrix ## Output: list $ expmCondF: Exponentialconditionnumber Frobeniusnorm; scalar ## $ expmCond1: Exponentialconditionnumber 1-Norm; scalar ## $ expm: e^A Matrixexponential; nxn Matrix d <- dim(A) if(length(d) != 2 || d[1] != d[2] || d[1] <= 1) stop("'A' must be a square matrix of dimension at least 2") method <- match.arg(method) give.exact <- match.arg(give.exact) switch(method, "1.est" = .expmCond.1(A, expm = expm), "F.est" = .expmCond.F (A, expm = expm, abstol=abstol, reltol=reltol), "exact" = .expmCond.X(A, expm = expm, give = give.exact), stop("invalid 'method'")) } ### The former 4 files from Michi Stadelmann --- all in one file ## byte date name ## ---- ------------ --------------- ## 2006 Jan 30 12:12 expcond.r ## 2086 Jan 30 10:45 expcondest1.r ## 1782 Jan 30 10:45 expcondestfrob.r ## 4544 Jan 30 12:22 expm2frech.r ###------------------ expcond.r ------------------------------------------- ## Function for *eXact* (slow!) calculation of the Exponentialconditionnumber ## ("1" and Frobenius-Norm). ## R-Implementation of Higham's Algorithm from the book ## "Functions of Matrices - Theory and Computation", chapter 3.4, algorithm 3.17 ## Step 1: Calculate Kroneckermatrix of L(A) ## Step 2: Calculate Expentialconditionnumber ("1" & Frobenius-Norm) .expmCond.X <- function(A, give= c("both", "1.norm", "F.norm"), expm = TRUE) { ## Input: A; nxn Matrix ## Output: list $ expmCondF: Exponentialconditionnumber Frobeniusnorm; scalar ## $ expmCond1: Exponentialconditionnumber 1-Norm; scalar ## $ expm: e^A Matrixexponential; nxn Matrix d <- dim(A) if(length(d) != 2 || d[1] != d[2] || d[1] <= 1) stop("'A' must be a square matrix of dimension at least 2") n <- d[1] ##---------STEP 1: Calculate Kroneckermatrix of L(A)------------------------ K <- matrix(0, n^2, n^2) E0 <- matrix(0, n,n) E.unit <- function(i,j) { ## Compute E_ij in R^{n x n} , the ij-th unit Matrix E <- E0 E[i,j] <- 1 E } give <- match.arg(give) jj <- 0 for (j in 1:n) { for (i in 1:n) { calc <- expmFrechet(A, E.unit(i,j), expm=(j == n) && (i == n)) K[, (jj <- jj + 1)] <- calc$Lexpm } } ##-------STEP 2 CALCULATE EXPONENTIALCONDITIONNUMBER ------------------------ ## Frobenius-Norm do.F <- (give %in% c("F.norm", "both")) do.1 <- (give %in% c("1.norm", "both")) if(do.F) normk <- sqrt(max(eigen(crossprod(K))$values)) # crossprod(K) := K' K list(expmCondF = ## Frobenius Norm if(do.F) normk * norm(A,"F") / norm(calc$expm,"F"), expmCond1 = ## 1-Norm if(do.1) norm(K,"1")* norm(A,"1") / (norm(calc$expm,"1")*n), expm = if(expm) calc$expm) } ###------------------ expcondest1.r --------------------------------------- ## Function for Estimation of the "1"-norm exponentialcondtionnumber based on ## the LAPACK marix norm estimator. ## R-Implementation of Higham's Algorithm from the book ## "Functions of Matrices - Theory and Computation", chapter 3.4, algorithm 3.21 ## Step 1: Estimate "1"-Norm of Kroneckermatrix K(A) ## This step is based on the equation: K(A)vec(E)=vec(L(A,E)) ## Step 2: Calculate Expentialconditionnumber ("1"-Norm) .expmCond.1 <- function(A, expm = TRUE) { ## Input: A; nxn Matrix ## Output: list $ expmCond: Exponentialconditionnumber "1"-Norm; scalar ## $ expm: e^A Matrixexponential; nxn Matrix ##-------STEP 1 ESTIMATE "1"-NORM FROM THE KRONECKERMATRIX-------------- ## Check if A is square d <- dim(A) if(length(d) != 2 || d[1] != d[2] || d[1] <= 1) stop("'A' must be a square matrix of dimension at least 2") n <- d[1] tA <- t(A) E <- matrix(1/n^2, n,n) calc <- expmFrechet(A,E) V <- calc$Lexpm G <- sum(abs(V)) Z <- sign(V) X <- expmFrechet(tA,Z, expm=FALSE)$Lexpm k <- 2 E0 <- matrix(0, n,n) repeat { ## at most steps k = 2, 3, 4, 5 j <- which.max(as.vector(abs(X))) Ej <- E0; Ej[j] <- 1 V <- expmFrechet(A,Ej, expm=FALSE)$Lexpm G <- sum(abs(V)) sV <- sign(V) if (identical(sV, Z) || identical(sV,-Z)) break Z <- sV X <- expmFrechet(tA,Z, expm=FALSE)$Lexpm k <- k+1 if (k > 5 || max(abs(X)) == X[j]) break } ## 'G' = gamma now is our desired lower bound ## Now, try another "lucky guess" and increase G if the guess *was* lucky : for (l in 1:(n^2)) { ## FIXME: vectorize this! X[l] <- (-1)^(l+1) * (1+(l-1)/(n^2-1)) } X <- expmFrechet(A,X, expm=FALSE)$Lexpm G. <- 2*sum(abs(X))/(3*n^2) if (G < G.) { message("'lucky guess' was better and is used for expmCond") G <- G. } ##-------STEP 2 CALCULATE EXPONENTIALCONDITIONNUMBER------------------ C1 <- G * norm(A,"1") / (norm(calc$expm,"1")*n) if(expm) list(condExpm = C1, expm = calc$expm) else C1 } ###------------------ expcondestfrob.r ------------------------------------ ## Function for estimation of the frobenius-Norm exponentialcondtionnumber based ## on the powermethod-matrixnorm estimation. ## R-Implementation of Higham's Algorithm from the book ## "Functions of Matrices - Theory and Computation", chapter 3.4, algorithm 3.19 ## Step 1: Estimate "2"-Norm of Kroneckermatrix K(A) ## This step is based on the equation: K(A)vec(E)=vec(L(A,E)) ## Step 2: Calculate Expentialconditionnumber (Frobenius-Norm) .expmCond.F <- function(A, abstol = 0.1, reltol = 1e-6, maxiter = 100, expm = TRUE) { ## Input: A; nxn Matrix ## Output: list C: C$expmCond: Exponentialconditionnumber Frobeniusnorm; scalar ## C$expm: e^A Matrixexponential; nxn Matrix ## Check if A is square d <- dim(A) if(length(d) != 2 || d[1] != d[2] || d[1] <= 1) stop("'A' must be a square matrix of dimension at least 2") n <- d[1] ##-------STEP 1 ESTIMATE 2-NORM OF KRONECKERMATRIX------------------------------- Z1 <- if(is(A,"Matrix")) Matrix(rnorm(n*n),n,n) else matrix(rnorm(n*n),n,n) tA <- t(A) calc <- expmFrechet(A,Z1) W1 <- calc$Lexpm Z1 <- expmFrechet(tA,W1, expm=FALSE)$Lexpm G2 <- norm(Z1,"F")/norm(W1,"F") it <- 0 repeat { G1 <- G2 W2 <- expmFrechet(A, Z1, expm=FALSE)$Lexpm Z2 <- expmFrechet(tA,W2, expm=FALSE)$Lexpm G2 <- norm(Z2,"F")/norm(W2,"F") Z1 <- Z2 dG <- abs(G1-G2) it <- it+1 if (it > maxiter || dG < abstol && dG < reltol*G2) break } if(it > maxiter) warning(gettextf("reached maxiter = %d iterations; tolerances too small?", maxiter), domain=NA) ##-------STEP 2 CALCULATE EXPONENTIALCONDITIONNUMBER-------------------- cF <- G2*norm(A,"F") / norm(calc$expm,"F") attr(cF, "iter") <- it if(expm) list(condExpm = cF, expm = calc$expm) else cF } ###------------------ expm2frech.r ---------------------------------------------- ## Calculation of e^A and the Exponential Frechet-Derivation L(A,E) ## with the Scaling & Squaring Method ## R-Implementation of Higham's Algorithm from the Article ## "Computing Fréchet Derivative of the Matrix Exponential, with an application ## to Condition Number Estimation", MIMS EPrint 2008.26, Algorithm 6.4 ## Step 1: Scaling (of A and E) ## Step 2: Padé-Approximation of e^A and L(A,E) ## Step 3: Squaring expmFrechet <- function(A,E, method = c("SPS","blockEnlarge"), expm = TRUE) { ## Input: A; nxn Matrix ## E; nxn Matrix ## Output: list X: X$expm; e^A Matrixeponential; nxn Matrix ## X$Lexpm; Exponential-Frechet-Derivative L(A,E); nxn Matrix ## Check if A is square d <- dim(A) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "A"), domain=NA) stopifnot(is.matrix(E)) if(!identical(d,dim(E))) stop("A and E need to have the same dimension") n <- d[1] if (n <= 1) { X <- exp(A) X2<- E*X return(if(expm) list(expm= X, Lexpm = X2) else list(Lexpm = X2)) } ## else n >= 2 ... non-trivial case : ------------- method <- match.arg(method) switch(method, "SPS" = .expmFrechet2008.26(A,E, expm = expm) , "blockEnlarge" = { ## From: Daniel Kressner @ math ETH Zurich ## To: Stadelmann Michael, Cc: Martin Maechler ## Subject: Frechet-Ableitung von f testen ## Date: Mon, 26 Jan 2009 ## mir ist noch ein weiterer Weg zum Test Deines ## Algorithmus fuer die Frechet-Ableitung eingefallen. ## Berechnet man f ([A E, 0 A]) ## dann enthaelt der (1,2)-Block die Ableitung von f an ## der Stelle A in Richtung E (siehe Higham). OO <- array(0, dim=d) B <- rbind(cbind(A, E), cbind(OO, A)) ## stopifnot(dim(B) == 2*d) fB <- expm.Higham08(B)[1:n, ] L <- fB[ , n+ 1:n] if(expm) list(expm = fB[ , 1:n], Lexpm = L) else list(Lexpm = L) }) } ## expmFrechet .expmFrechet2008.26 <- function(A, E, expm = TRUE) { ## No error checking! --> not to be called by the user! ## R-Implementation of Higham's Algorithm from the Article ## "Computing Fréchet Derivative of the Matrix Exponential, with an application ## to Condition Number Estimation", MIMS EPrint 2008.26, Algorithm 6.4 ## Step 1: Scaling (of A and E) ## Step 2: Padé-Approximation of e^A and L(A,E) ## Step 3: Squaring ##-----------STEP 1 & STEP 2: SCALING & PADÉ APPROXIMATION------------------- ## Informations about the given matrix nA <- norm(A ,"1") ## == Matrix::norm n <- nrow(A)# == ncol(A) .. tested "in the caller" ## try to remain in the same matrix class system: I <- if(is(A,"Matrix")) Diagonal(n) else diag(n) ## If the norm is small enough, use directly the Padé-Approximation (PA) if (nA <= 1.78) { t <- c(0.0108,0.2,0.783,1.78) ## the minimal m for the PA : l <- which.max(nA <= t) ## Calculate PA for e^A and L(A,E) C <- rbind(c(120,60,12,1,0,0,0,0,0,0), c(30240,15120,3360,420,30,1,0,0,0,0), c(17297280,8648640,1995840,277200,25200,1512,56,1,0,0), c(17643225600,8821612800,2075673600,302702400,30270240, 2162160,110880,3960,90,1)) [l , ] # only need l-th row P <- I U <- C[2]*I V <- C[1]*I A2 <- A %*% A M2 <- A %*% E + E %*% A M <- M2 LU <- C[4]*M LV <- C[3]*M oC <- 2 for (k in seq_len(l-1)) { ## oC == 2k ## PA e^A P <- P %*% A2 U <- U+C[oC+ 2]*P V <- V+C[oC+ 1]*P ## PA L(A,E) M <- A2 %*% M + M2 %*% P LU <- LU + C[oC+ 4]*M LV <- LV + C[oC+ 3]*M oC <- oC + 2 } ## PA e^A & L(A,E) P <- P %*% A2 U <- U + C[oC+ 2]*P LU <- A %*% LU + E %*% U U <- A %*% U V <- V + C[oC+ 1]*P X <- solve(V-U, V+U) X2 <- solve(V-U, LU+LV + (LU-LV)%*%X) } ## Else, check if norm of A is small enough for PA with m=13. ## If not, scale the matrix else { s <- log2(nA/4.74) B <- A D <- E ## Scaling if (s > 0){ s <- ceiling(s) B <- A/(2^s) D <- D/(2^s) } C. <- c(64764752532480000,32382376266240000,7771770303897600,1187353796428800, 129060195264000,10559470521600,670442572800,33522128640,1323241920, 40840800,960960,16380,182,1) ## Calculate PA ## PA e^A B2 <- B%*%B B4 <- B2%*%B2 B6 <- B2%*%B4 W1 <- C.[14]*B6+ C.[12]*B4+ C.[10]*B2 W2 <- C.[ 8]*B6+ C.[ 6]*B4+ C.[ 4]*B2+C.[2]*I Z1 <- C.[13]*B6+ C.[11]*B4+ C.[ 9]*B2 Z2 <- C.[ 7]*B6+ C.[ 5]*B4+ C.[ 3]*B2+C.[1]*I W <- B6%*%W1+W2 U <- B%*%W V <- B6%*%Z1+Z2 ## PA L(A,E) M2 <- B%*%D + D%*%B M4 <- B2%*%M2 + M2%*%B2 M6 <- B4%*%M2 + M4%*%B2 LW1 <- C.[14]*M6+ C.[12]*M4+ C.[10]*M2 LW2 <- C.[ 8]*M6+ C.[ 6]*M4+ C.[ 4]*M2 LZ1 <- C.[13]*M6+ C.[11]*M4+ C.[ 9]*M2 LZ2 <- C.[ 7]*M6+ C.[ 5]*M4+ C.[ 3]*M2 LW <- B6%*%LW1 + M6%*%W1 + LW2 LU <- B%*%LW + D%*%W LV <- B6%*%LZ1 + M6%*%Z1 + LZ2 X <- solve(V-U, V+U) X2 <- solve(V-U, LU+LV + (LU-LV)%*%X) ##----------STEP 3 SQUARING---------------------------------------------- ## Squaring if (s > 0) for (t in seq_len(s)) { X2 <- X2 %*% X + X %*% X2 if(expm || t != s) X <- X %*% X } } if(expm) list(expm = X, Lexpm = X2) else list(Lexpm = X2) } ## .expmFrechet2008.26 expm/R/sqrtm.R0000644000176200001440000001234114107534174012724 0ustar liggesusers#### Define sqrtm() --- was Michael Stadelmann's root.r #### ======= ~~~~~~ ##------OVERVIEW---------------------------------------------------------------- ## Input: A; nxn matrix, no eigenvalues <=0, not singular ## Output: root of matrix A, nxn Matrix ## Function for calculation of A^(1/2) with the real Schur decomposition ## Step 0: real Schur decomposition T of A ## Step 1: Aalyse block structure of T ## Step 2: Calculate diagonal elements/blocks of T^(1/2) ## Step 3: Calculate superdiagonal elements/blocks of T^(1/2) ## Step 4: reverse Schur decompostion ## R-Implementation of Higham's Algorithm from the Book ## "Functions of Matrices - Theory and Computation", Chapter 6, Algorithm 6.7 ## NB: Much in parallel with rootS() in ./logm.Higham08.R <<< keep in sync ## ~~~~~ ~~~~~~~~~~~~~~~ sqrtm <- function(x) { ## Generate Basic informations of matrix x ## FIXME : should work for "Matrix" too, hence _not_ S <- as.matrix(x) d <- dim(x) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "x"), domain=NA) ##MM: No need to really check here; we get correct error msg later anyway ## and don't need to compute det() here, in the good cases ! ## if (det(x) == 0) stop("'x' is singular") n <- d[1] ##------- STEP 0: Schur Decomposition --------------------------------------- Sch.x <- Schur(Matrix(x)) ## <- {FIXME [Matrix]} ev <- Sch.x@EValues if(getOption("verbose") && any(abs(Arg(ev) - pi) < 1e-7)) ## Let's see what works: temporarily *NOT* stop()ping : message(gettextf("'x' has negative real eigenvalues; maybe ok for %s", "sqrtm()"), domain=NA) S <- as.matrix(Sch.x@T) Q <- as.matrix(Sch.x@Q) ##---------STEP 1: Analyse block structure----------------------------------- if(n > 1L) { ## Count 2x2 blocks (as Schur(x) is the real Schur Decompostion) J.has.2 <- S[cbind(2:n, 1:(n-1))] != 0 k <- sum(J.has.2) ## := number of non-zero SUB-diagonals } else k <- 0L ## Generate Blockstructure and save it as R.index R.index <- vector("list",n-k) l <- 1L i <- 1L while(i < n) { ## i advances by 1 or 2, depending on 1- or 2- Jordan Block if (S[i+1L,i] == 0) { R.index[[l]] <- i } else { i1 <- i+1L R.index[[l]] <- c(i,i1) # = i:(i+1) i <- i1 } i <- i+1L l <- l+1L } if (is.null(R.index[[n-k]])) { # needed; FIXME: should be able to "know" ##message(gettextf("R.index[n-k = %d]] is NULL, set to n=%d", n-k,n), domain=NA) R.index[[n-k]] <- n } ##---------STEP 2: Calculate diagonal elements/blocks------------------------ ## Calculate the root of the diagonal blocks of the Schur Decompostion S I <- diag(2) X <- matrix(0,n,n) for (j in seq_len(n-k)) { ij <- R.index[[j]] if (length(ij) == 1L) { X[ij,ij] <- if((.s <- S[ij,ij]) < 0) sqrt(.s + 0i) else sqrt(.s) } else { ev1 <- ev[ij[1]] r1 <- Re(sqrt(ev1)) ## sqrt() ... X[ij,ij] <- r1*I + 1/(2*r1)*(S[ij,ij] - Re(ev1)*I) } } ##---------STEP 3: Calculate superdiagonal elements/blocks------------------- ## Calculate the remaining, not-diagonal blocks if (n-k > 1L) for (j in 2L:(n-k)) { ij <- R.index[[j]] for (i in (j-1L):1L) { ii <- R.index[[i]] sumU <- 0 ## Calculation for 1x1 Blocks if (length(ij) == 1L & length(ii) == 1L) { if (j-i > 1L) for (l in (i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(X[ii,ii]+X[ij,ij],S[ii,ij]-sumU) } ## Calculation for 1x2 Blocks else if (length(ij) == 2 & length(ii) == 1L ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(t(X[ii,ii]*I + X[ij,ij]), as.vector(S[ii,ij] - sumU)) } ## Calculation for 2x1 Blocks else if (length(ij) == 1L & length(ii) == 2 ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(X[ii,ii]+X[ij,ij]*I, S[ii,ij]-sumU) } ## Calculation for 2x2 Blocks with special equation for solver else if (length(ij) == 2 & length(ii) == 2 ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il] %*% X[il,ij] else X[ii,il] %*% t(X[il,ij]) } } tUii <- matrix(0,4,4) tUii[1:2,1:2] <- X[ii,ii] tUii[3:4,3:4] <- X[ii,ii] tUjj <- matrix(0,4,4) tUjj[1:2,1:2] <- t(X[ij,ij])[1L,1L]*I tUjj[3:4,3:4] <- t(X[ij,ij])[2L,2L]*I tUjj[1:2,3:4] <- t(X[ij,ij])[1L,2L]*I tUjj[3:4,1:2] <- t(X[ij,ij])[2L,1L]*I X[ii,ij] <- solve(tUii+tUjj, as.vector(S[ii,ij]-sumU)) } } ## for (i in (j-1):1) .. } ## for (j in 2:(n-k)) ... ##------- STEP 4: Reverse the Schur Decomposition -------------------------- ## Reverse the Schur Decomposition Q %*% X %*% solve(Q) } expm/R/balance.R0000644000176200001440000000144514547727173013161 0ustar liggesusers## NOTA BENE: In Matlab, there's the function balance(.) which ## calls LAPACK's dgebal *AND* which has the option to also return the ## transformation *diagonal* matrix D , not just the transformed matrix. balance <- function(A, job = c("B","N", "P","S")) { .Call(R_dgebal, if(is.numeric(A)) A else as(A, "matrix"), match.arg(job)) } ## dgebal <- balance ## till ## 2020-07-21: Finally deprecated: dgebal <- function(A, job = c("B","N", "P","S")) { .Deprecated("balance") .Call("R_dgebal", A, match.arg(job)) } ## Not exported, used to make 'R CMD check ' be faster *or* more extensive: doExtras <- function(int = interactive()) { int || nzchar(Sys.getenv("R_expm_check_extra")) || identical("true", unname(Sys.getenv("R_PKG_CHECKING_doExtras"))) } expm/R/logm.Higham08.R0000644000176200001440000002376514107534174014074 0ustar liggesusers##------OVERVIEW---------------------------------------------------------------- ## Input: A; nxn Matrix, no eigenvalues <=0, not singular ## Output: log(A); Matrixlogarithm; nxn Matrix ## Function for Calculation of log(A) with the Inverse Scaling&Squaring Method ## Step 0: Schur Decompostion Tr ## Step 1: Scaling (root of Tr) ## Step 2: Padé-Approximation ## Step 3: Squaring ## Step 4: Reverse Schur Decomposition ## R-Implementation of Higham's Algorithm from the Book ## "Functions of Matrices - Theory and Computation", Chapter 11, Algorithm 11.9 ##-------CODE------------------------------------------------------------------- ## The coefficients for the Padé-approximation can be computed at install time: ## r: exponents are in (-51):(-56) ## p: exponents are in c((-47):(-53), -56) logm.H08.r <- rbind(c(5003999585967230*2^(-54), 8006399337547537*2^(-54), 5/18, 0,0,0,0), c(5640779706068081*2^(-51), 8899746432686114*2^(-53), 8767290225458872*2^(-54), 6733946100265013*2^(-55), 0,0,0), c(5686538473148996*2^(-51), 4670441098084653*2^(-52), 5124095576030447*2^(-53), 5604406634440294*2^(-54), 8956332917077493*2^(-56), 0,0), c(5712804453675980*2^(-51), 4795663223967718*2^(-52), 5535461316768070*2^(-53), 6805310445892841*2^(-54), 7824302940658783*2^(-55), 6388318485698934*2^(-56), 0), c(5729264333934497*2^(-51), 4873628951352824*2^(-52), 5788422587681293*2^(-53), 7529283295392226*2^(-54), 4892742764696865*2^(-54), 5786545115272933*2^(-55), 4786997716777457*2^(-56))) logm.H08.p <- - rbind(c(7992072898328873*2^(-53), 1/2, 8121010851296995*2^(-56), 0,0,0,0), c(8107950463991866*2^(-49), 6823439817291852*2^(-51), 6721885580294475*2^(-52), 4839623620596807*2^(-52), 0,0,0), c(6000309411699298*2^(-48), 4878981751356277*2^(-50), 2, 5854649940415304*2^(-52), 4725262033344781*2^(-52),0,0), c(8336234321115872*2^(-48), 6646582649377394*2^(-50), 5915042177386279*2^(-51), 7271968136730531*2^(-52), 5422073417188307*2^(-52), 4660978705505908*2^(-52), 0), c(5530820008925390*2^(-47), 8712075454469181*2^(-50), 7579841581383744*2^(-51), 4503599627370617*2^(-51), 6406963985981958*2^(-52), 5171999978649488*2^(-52), 4621190647118544*2^(-52))) logm.Higham08 <- function(x) { ## work with "Matrix" too: x<-as.matrix(x) ##MM: No need to really check here; we get correct error msg later anyway ## and don't need to compute det() here, in the good cases ! ## if (det(x) == 0) stop("'x' is singular") ##-------Step 0: Schur Decomposition----------------------------------------- ## Schur() checks for square matrix also: Sch.x <- Schur(Matrix(x, sparse=FALSE)) ## FIXME 'sparse=FALSE' is workaround - good as long Matrix has no sparse Schur() ev <- Sch.x@EValues if(getOption("verbose") && any(abs(Arg(ev) - pi) < 1e-7)) ## Let's see what works: temporarily *NOT* stop()ping : message(gettextf("'x' has negative real eigenvalues; maybe ok for %s", "logm()"), domain=NA) n <- Sch.x@Dim[1] Tr <- as.matrix(Sch.x@T) Q <- as.matrix(Sch.x@Q) ##----- Step 1: [Inverse] Scaling ------------------------------------------- I <- diag(n) thMax <- 0.264 theta <- c(0.0162, 0.0539, 0.114, 0.187, thMax) p <- k <- 0 ; t.o <- -1 ## NB: The following could loop forever, e.g., for logm(Diagonal(x=1:0)) repeat{ t <- norm(Tr - I, "1") # norm(x, .) : currently x is coerced to dgeMatrix if(is.na(t)) { warning(sprintf(ngettext(k, "NA/NaN from || Tr - I || after %d step.\n%s", "NA/NaN from || Tr - I || after %d steps.\n%s"), k, "The matrix logarithm may not exist for this matrix.")) return(array(t, dim=dim(Tr))) } if (t < thMax) { ## FIXME: use findInterval() j2 <- which.max( t <= theta) j1 <- which.max( (t/2) <= theta) if ((j2-j1 <= 1) || ((p <- p+1) == 2)) { m <- j2 ## m := order of the Padé-approximation break } } else if(k > 20 && abs(t.o - t) < 1e-7*t) { ## warning(gettextf("Inverse scaling did not work (t = %g).\n", t), "The matrix logarithm may not exist for this matrix.", "Setting m = 3 arbitrarily.") m <- 3 break } Tr <- rootS(Tr)##--> Matrix Square root of Jordan T ## ----- [see below; compare with ./sqrtm.R t.o <- t k <- k+1 } if(getOption("verbose")) message(gettextf("logm.Higham08() -> (k, m) = (%d, %d)", k,m), domain=NA) ##------ Step 2: Padé-Approximation ----------------------------------------- ## of order m : r.m <- logm.H08.r[m,] p.m <- logm.H08.p[m,] X <- 0 Tr <- Tr-I for (s in 1:(m+2)) { X <- X + r.m[s]*solve(Tr - p.m[s]*I, Tr) } ##--- Step 3 & 4: Squaring & reverse Schur Decomposition ----------------- 2^k* Q %*% X %*% solve(Q) } ### --- was rootS.r ----------------------------------------------------------- ### ~~~~~~~ ##------OVERVIEW---------------------------------------------------------------- ## Input: UT; nxn upper triangular block matrix (real Schur decomposition) ## Output: root of matrix UT, nxn upper triangular Matrix ## Function for calculation of UT^(1/2), which is used for the logarithm function ## Step 0: Analyse block structure ## Step 1: Calculate diagonal elements/blocks ## Step 2: Calculate superdiagonal elements/blocks ## R-Implementation of Higham's Algorithm from the Book ## "Functions of Matrices - Theory and Computation", Chapter 6, Algorithm 6.7 ## NB: Much in parallel with sqrtm() in ./sqrtm.R <<< keep in sync ## ~~~~~ ~~~~~~~ rootS <- function(x) { ## Generate Basic informations of Matrix x stopifnot(length(d <- dim(x)) == 2, is.numeric(d), (n <- d[1]) == d[2], n >= 1) ## FIXME : should work for "Matrix" too: not S <- as.matrix(x) S <- x ##------- STEP 0: Analyse block structure ---------------------------------- if(n > 1L) { ## Count 2x2 blocks (as Schur(x) is the real Schur Decompostion) J.has.2 <- S[cbind(2:n, 1:(n-1))] != 0 k <- sum(J.has.2) ## := number of non-zero SUB-diagonals } else k <- 0L ## Generate Blockstructure and save it as R.index R.index <- vector("list",n-k) l <- 1L i <- 1L while(i < n) { ## i advances by 1 or 2, depending on 1- or 2- Jordan Block if (S[i+1L,i] == 0) { R.index[[l]] <- i } else { i1 <- i+1L R.index[[l]] <- c(i,i1) # = i:(i+1) i <- i1 } i <- i+1L l <- l+1L } if (is.null(R.index[[n-k]])) { # needed; FIXME: should be able to "know" ##message(gettextf("R.index[n-k = %d]] is NULL, set to n=%d", n-k,n), domain=NA) R.index[[n-k]] <- n } ##---------STEP 1: Calculate diagonal elements/blocks------------------------ ## Calculate the root of the diagonal blocks of the Schur Decompostion S I <- diag(2) X <- matrix(0,n,n) for (j in seq_len(n-k)) { ij <- R.index[[j]] if (length(ij) == 1L) { ## Sij <- S[ij,ij] ## if(Sij < 0) ## ## FIXME(?) : in sqrtm(), we take *complex* sqrt() if needed : ## ## ----- but afterwards norm(Tr - I, "1") fails with complex ## ## Sij <- complex(real = Sij, imaginary = 0) ## stop("negative diagonal entry -- matrix square does not exist") ## X[ij,ij] <- sqrt(Sij) X[ij,ij] <- sqrt(S[ij,ij]) } else { ## "FIXME"(better algorithm): only need largest eigen value ev1 <- eigen(S[ij,ij], only.values=TRUE)$values[1] r1 <- Re(sqrt(ev1)) ## sqrt() ... X[ij,ij] <- r1*I + 1/(2*r1)*(S[ij,ij] - Re(ev1)*I) } } ### ___ FIXME __ code re-use: All the following is identical to 'STEP 3' in sqrtm() ### ----- and almost all of STEP 1 above is == 'STEP 2' of sqrtm() ##---------STEP 2: Calculate superdiagonal elements/blocks------------------- ## Calculate the remaining, not-diagonal blocks if (n-k > 1L) for (j in 2L:(n-k)) { ij <- R.index[[j]] for (i in (j-1L):1L) { ii <- R.index[[i]] sumU <- 0 ## Calculation for 1x1 Blocks if (length(ij) == 1L & length(ii) == 1L ) { if (j-i > 1L) for (l in (i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(X[ii,ii]+X[ij,ij],S[ii,ij]-sumU) } ## Calculation for 1x2 Blocks else if (length(ij) == 2 & length(ii) == 1L ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(t(X[ii,ii]*I + X[ij,ij]), as.vector(S[ii,ij] - sumU)) } ## Calculation for 2x1 Blocks else if (length(ij) == 1L & length(ii) == 2 ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(X[ii,ii]+X[ij,ij]*I,S[ii,ij]-sumU) } ## Calculation for 2x2 Blocks with special equation for solver else if (length(ij) == 2 & length(ii) == 2 ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il] %*% X[il,ij] else X[ii,il] %*% t(X[il,ij]) } } tUii <- matrix(0,4,4) tUii[1:2,1:2] <- X[ii,ii] tUii[3:4,3:4] <- X[ii,ii] tUjj <- matrix(0,4,4) tUjj[1:2,1:2] <- t(X[ij,ij])[1L,1L]*I tUjj[3:4,3:4] <- t(X[ij,ij])[2L,2L]*I tUjj[1:2,3:4] <- t(X[ij,ij])[1L,2L]*I tUjj[3:4,1:2] <- t(X[ij,ij])[2L,1L]*I X[ii,ij] <- solve(tUii+tUjj,as.vector(S[ii,ij]-sumU)) } } } X } expm/R/expm2.R0000644000176200001440000001063014107534174012610 0ustar liggesusers ##' Calculation of e^A with the Scaling & Squaring Method with Balancing ##' according to Higham (2008) ##' ##' R-Implementation of Higham's Algorithm from the Book (2008) ##' "Functions of Matrices - Theory and Computation", Chapter 10, Algorithm 10.20 ##' Step 0: Balancing ##' Step 1: Scaling ##' Step 2: Padé-Approximation ##' Step 3: Squaring ##' Step 4: Reverse Balancing ##' ##' @title Matrix Exponential with Scaling & Squaring and Balancing ##' @param A nxn Matrix ##' @param balancing logical indicating if balancing (step 0) should be applied ##' @return e^A Matrixeponential; nxn Matrix ##' @author Martin Maechler expm.Higham08 <- function(A, balancing=TRUE) { ## Check if A is square d <- dim(A) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "A"), domain=NA) n <- d[1] if (n <= 1) return(exp(A)) ## else n >= 2 ... non-trivial case : ------------- ##---------STEP 0: BALANCING------------------------------------------------ ## if balancing is asked for, balance the matrix A if (balancing) { baP <- balance(A, "P")# -> error for non-classical matrix -- "FIXME": balance() baS <- balance(baP$z, "S") A <- baS$z } ##--------STEP 1 and STEP 2 SCALING & PADÉ APPROXIMATION-------------------- ## Informations about the given matrix nA <- Matrix::norm(A, "1") ## try to remain in the same matrix class system: I <- if(is(A,"Matrix")) Diagonal(n) else diag(n) ## If the norm is small enough, use the Padé-Approximation (PA) directly if (nA <= 2.1) { t <- c(0.015, 0.25, 0.95, 2.1) ## the minimal m for the PA : l <- which.max(nA <= t) ## Calculate PA C <- rbind(c(120,60,12,1,0,0,0,0,0,0), c(30240,15120,3360,420,30,1,0,0,0,0), c(17297280,8648640,1995840,277200,25200,1512,56,1,0,0), c(17643225600,8821612800,2075673600,302702400,30270240, 2162160,110880,3960,90,1)) A2 <- A %*% A P <- I U <- C[l,2]*I V <- C[l,1]*I for (k in 1:l) { P <- P %*% A2 U <- U + C[l,(2*k)+2]*P V <- V + C[l,(2*k)+1]*P } U <- A %*% U X <- solve(V-U,V+U) } ## Else, check if norm of A is small enough for m=13. ## If not, scale the matrix else { s <- log2(nA/5.4) B <- A ## Scaling if (s > 0) { s <- ceiling(s) B <- B/(2^s) } ## Calculate PA c. <- c(64764752532480000,32382376266240000,7771770303897600, 1187353796428800, 129060195264000,10559470521600, 670442572800, 33522128640, 1323241920, 40840800,960960,16380, 182,1) B2 <- B %*% B B4 <- B2 %*% B2 B6 <- B2 %*% B4 U <- B %*% (B6 %*% (c.[14]*B6 + c.[12]*B4 + c.[10]*B2) + c.[8]*B6 + c.[6]*B4 + c.[4]*B2 + c.[2]*I) V <- B6 %*% (c.[13]*B6 + c.[11]*B4 + c.[9]*B2) + c.[7]*B6 + c.[5]*B4 + c.[3]*B2 + c.[1]*I X <- solve(V-U,V+U) ##---------------STEP 3 SQUARING---------------------------------------------- if (s > 0) for (t in 1:s) X <- X %*% X } ##-----------------STEP 4 REVERSE BALANCING--------------------------------- if (balancing) { ## reverse the balancing d <- baS$scale X <- X * (d * rep(1/d, each = n)) ## apply inverse permutation (of rows and columns): pp <- as.integer(baP$scale) if(baP$i1 > 1) { ## The lower part for(i in (baP$i1-1):1) { # 'p1' in *reverse* order tt <- X[,i]; X[,i] <- X[,pp[i]]; X[,pp[i]] <- tt tt <- X[i,]; X[i,] <- X[pp[i],]; X[pp[i],] <- tt } } if(baP$i2 < n) { ## The upper part for(i in (baP$i2+1):n) { # 'p2' in *forward* order ## swap i <-> pp[i] both rows and columns tt <- X[,i]; X[,i] <- X[,pp[i]]; X[,pp[i]] <- tt tt <- X[i,]; X[i,] <- X[pp[i],]; X[pp[i],] <- tt } } } X } ##' Matrix Exponential -- using Al-Mohy and Higham (2009)'s algorithm ##' --> ../src/matexp_MH09.c ##' @param x square matrix ##' @param p the order of the Pade' approximation, 1 <= p <= 13. The ##' default, 6, is what \file{expokit} uses. expm.AlMoHi09 <- function(x, p = 6) { d <- dim(x) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "x"), domain=NA) stopifnot(length(p <- as.integer(p)) == 1) if (p < 1 || p > 13) stop("Pade approximation order 'p' must be between 1 and 13.") .Call(R_matexp_MH09, if(is.numeric(x)) x else as(x, "matrix"), p) } expm/R/expm.R0000644000176200001440000001634214107534174012534 0ustar liggesusers### ===== File part of R package expm ===== ### ### Function to compute the matrix exponential ### ### exp(M) = sum(n = 0:Inf; M^n / n!), ### ### where M is an (n x n) matrix. ### expm.s.Pade.s <- function(x, order, n=nrow(x)) { ## no checking here; this is not to be called by the user ## try have this work with "mpfrMatrix" <==> solve() ## s := the number of [s]quarings e <- ceiling(log2(max(rowSums(abs(x))))) s <- max(e+1, 0) ## preconditions x : x <- x / (2^s) ## Pade approximation for exp(x) c <- .5 D <- diag(1, n) E <- D + c*x D <- D - c*x X <- x p <- TRUE for(k in 2:order) { c <- c * (order-k+1) / (k*(2*order-k+1)) X <- x %*% X # now X = x ^ k cX <- c*X E <- E + cX D <- if(p) D + cX else D - cX p <- !p } E <- solve(D, E) ## Undo the scaling by repeated squaring : for(k in seq_len(s)) E <- E %*% E E } expm.methSparse <- c("Higham08", "R_Eigen", "R_Pade") ## keep this list up-to-date - test by setting R_EXPM_NO_DENSE_COERCION ## but NOTE: It may make sense to *keep* the message() about coercion to dense (memory blow up!) expm <- function(x, method = c("Higham08.b", "Higham08", "AlMohy-Hi09", "Ward77", "PadeRBS", "Pade", "Taylor", "PadeO", "TaylorO", "R_Eigen", "R_Pade", "R_Ward77", "hybrid_Eigen_Ward"), order = 8, trySym = TRUE, tol = .Machine$double.eps, do.sparseMsg = TRUE, preconditioning = c("2bal", "1bal", "buggy")) { ## some methods work for "matrix", "Matrix", or "mpfrMatrix", iff solve(.,.) worked: stopifnot(is.numeric(x) || (isM <- inherits(x, "dMatrix")) || inherits(x, "mpfrMatrix")) if(length(d <- dim(x)) != 2) stop("argument is not a matrix") if (d[1] != d[2]) stop("matrix not square") method <- match.arg(method) checkSparse <- !nzchar(Sys.getenv("R_EXPM_NO_DENSE_COERCION")) isM <- !is.numeric(x) && isM if(isM && checkSparse) { # i.e., a "dMatrix" if(!(method %in% expm.methSparse) && is(x, "sparseMatrix")) { if(do.sparseMsg) message(gettextf("coercing to dense matrix, as required by method %s", dQuote(method)), domain=NA) x <- as(x, "denseMatrix") } } switch(method, "AlMohy-Hi09" = expm.AlMoHi09(x, p = order) , "Higham08.b" = expm.Higham08(x, balancing = TRUE) , "Higham08" = expm.Higham08(x, balancing = FALSE) , "Ward77" = { ## AUTHORS: Christophe Dutang, Vincent Goulet at act ulaval ca ## built on "Matrix" package, built on 'octave' code ## Martin Maechler, for the preconditioning etc if(!is.numeric(x)) x <- as(x, "matrix") switch(match.arg(preconditioning), "2bal" = .Call(do_expm, x, "Ward77"), "1bal" = .Call(do_expm, x, "Ward77_1"), "buggy"= .Call(do_expm, x, "buggy_Ward77"), stop("invalid 'preconditioning'")) }, "R_Eigen" = { ## matrix exponential using eigenvalues / spectral decomposition : ## == Dubious Way 'Method 14' : is ## good for 'symmetric' or 'orthogonal' (or other 'normal' : A'A = AA' ): ## MM: improved from mexp2() with 'trySym' and isSymmetric() isSym <- if(trySym) isSymmetric.matrix(x) else FALSE z <- eigen(x, symmetric = isSym) V <- z$vectors Vi <- if(isSym) t(V) else solve(V) Re(V %*% ( exp(z$values) * Vi)) ## == ##(V %*% diag(exp(z$values)) %*% Vi) }, "hybrid_Eigen_Ward" = { ## AUTHOR: Christophe Dutang ## matrix exponential using eigenvalues / spectral decomposition and ## Ward(1977) algorithm if x is numerically non diagonalisable if(!is.numeric(x)) x <- as(x, "matrix") .Call(do_expm_eigen, x, tol) }, "R_Pade"= { ## use scaling + Pade + squaring with R code: ## matrix exponential using a scaling and squaring algorithm ## with a Pade approximation ## source code translated from expmdemo1.m in Matlab ## by Stig Mortensen , ## prettified by MM -- works for "matrix" or "Matrix" matrices ! stopifnot(order >= 2) expm.s.Pade.s(x, order, n=d[1]) }, "R_Ward77" = { ## R implementation of "Ward(1977)" ## also works for "Matrix" matrices stopifnot(order >= 2) n <- d[1] ## Preconditioning Step 1: shift diagonal by average diagonal trShift <- sum(d.x <- diag(x)) if(trShift) { trShift <- trShift/n diag(x) <- d.x - trShift } ## Preconditioning Step 2: balancing with balance. ## ------ ## For now, do like the octave implementation ## TODO later: use "B" (faster; better condition of result) baP <- balance(x, "P") baS <- balance(baP$z, "S") x <- expm.s.Pade.s(baS$z, order) ## ------------- scaling + Pade + squaring ------ ## i.e., entails Preconditioning Step 3 (and its reverse) ## Reverse step 2: ------------------ ## ## Step 2 b: apply inverse scaling d <- baS$scale x <- x * (d * rep(1/d, each = n)) ## ## Step 2 a: apply inverse permutation (of rows and columns): pp <- as.integer(baP$scale) if(baP$i1 > 1) { ## The lower part for(i in (baP$i1-1):1) { # 'p1' in *reverse* order tt <- x[,i]; x[,i] <- x[,pp[i]]; x[,pp[i]] <- tt tt <- x[i,]; x[i,] <- x[pp[i],]; x[pp[i],] <- tt } } if(baP$i2 < n) { ## The upper part for(i in (baP$i2+1):n) { # 'p2' in *forward* order ## swap i <-> pp[i] both rows and columns tt <- x[,i]; x[,i] <- x[,pp[i]]; x[,pp[i]] <- tt tt <- x[i,]; x[i,] <- x[pp[i],]; x[pp[i],] <- tt } } ## reverse step 1 (diagonal shift) if(trShift) { exp(trShift) * x } else x }, "PadeRBS" = { ## the "expofit" method by Roger B. Sidje (U.Queensland, AU) if(!is.numeric(x)) x <- as(x, "matrix") stopifnot((order <- as.integer(order)) >= 1) if(!is.double(x)) storage.mode(x) <- "double" Fobj <- .Fortran(matexpRBS, order, # IDEG 1 as.integer(d[1]), # M 2 T = 1., # T 3 H = x, # H 4 iflag = integer(1) # IFLAG 5 )[c("H","iflag")] if(Fobj[["iflag"]] < 0) stop("Unable to determine matrix exponential") Fobj[["H"]] } , { ## the "mexp" methods by ## AUTHORS: Marina Shapira and David Firth -------------- if(!is.numeric(x)) x <- as(x, "matrix") if(!is.double(x)) storage.mode(x) <- "double" order <- as.integer(order) ## MM: a "silly" way to code the method / order ntaylor <- npade <- 0L if (substr(method,1,4) == "Pade") npade <- order else ntaylor <- order res <- if(identical(grep("O$", method), 1L)) .Fortran(matrexpO, X = x, size = d[1], ntaylor, npade, accuracy = double(1))[c("X", "accuracy")] else .Fortran(matrexp, X = x, size = d[1], ntaylor, npade, accuracy = double(1))[c("X", "accuracy")] structure(res$X, accuracy = res$accuracy) })## end{switch} } expm/MD50000644000176200001440000000703014547745062011551 0ustar liggesusersfffd6047121f37f44b94e5ddd70b00aa *ChangeLog 468b8b60176a161101f630a214320bd4 *DESCRIPTION 126f13f1117be0fcb55ba5ca4e6ffc97 *NAMESPACE addf62fa0032a6be26e9a38e6cfbd5b0 *R/balance.R 40c90b349a501f474c14ea9a70016789 *R/expm.R 34dfdc5f3fc2aff5c642eb1aca24d56b *R/expm2.R f15efdadae53fd8445cd9064188e7ac9 *R/expmCond-all.R dbc522a7c2b2a50ce050493daba661e0 *R/expm_vec.R 23da2e8766976b676dd5913eecd86d94 *R/logm.Higham08.R 38bab978acbf5b04597dfbd580a9e9f5 *R/logm.R 45e07bacddb49c9238b3e9d1767992f7 *R/matpow.R bc755b8cc2fb5ecfd62786985776d3e2 *R/sqrtm.R 62dbcce738cc4dafde0cbb7a5b92aabc *TODO 8faf250d78a120ba4c7ea2186efddd24 *build/partial.rdb 20aa8a1ca545862228969e6ff56038aa *build/vignette.rds d31374f27f2d6e5c5b459e0b1541cbbd *data/matStig.R b544e04306e3002383308b520878ea59 *demo/00Index 2f15f528464b6bf3205954e451b11683 *demo/balanceTst.R 84bfbe96d9fa970b3dffd244766bed24 *demo/exact-fn.R fa79ca82d01fb70f9267f5a9d0237041 *demo/expm.R 07ac2c2c3add1d02cb9ecfbdfb2ac077 *inst/doc/expm.R 61655a9c17ec4f2e874bc1ee2af64e96 *inst/doc/expm.Rnw 02fe8b5ac1bd322ba55e4e6e5622f895 *inst/doc/expm.pdf 959a1dbb1f1633688fa783b489503e7a *inst/po/de/LC_MESSAGES/R-expm.mo e1c6033c302666b96039a0c50fb0d5ee *inst/po/en@quot/LC_MESSAGES/R-expm.mo 686ec00b0ae0f137c6f6edc3825e450c *inst/po/en@quot/LC_MESSAGES/expm.mo 790f34095af968c11197315394be494b *inst/po/expm-de/LC_MESSAGES/expm.mo 26ad8d9fef04a4dd36adb264608be90f *inst/po/fr/LC_MESSAGES/expm.mo 274e76f34f3671b5db44d6a1dbc701a9 *inst/po/fr/LC_MESSAGES/fr.mo 267065beb76d42a8eaa2be71b625b1e9 *inst/test-tools.R 235a59f917a71d3ace36849e8a748839 *man/balance.Rd 2681415ac9d47fdf5223de806c84042d *man/expAtv.Rd f7816f7c3bda2912173c74ab79f58cb2 *man/expm.Higham08.Rd f6cdcde1348cee9b7856a306591c013c *man/expm.Rd 72507358477c557080b129848dc9ecbc *man/expmCond.Rd 697d7311ef6c64384bedb7a9c345b41c *man/expmFrechet.Rd 4bebe0d3ed49104170f40b5afd854d34 *man/logm.Rd 0835f0173e75dabe7a9b97ee7a540fd5 *man/matStig.Rd 25ffdff79449fea67c0f0ae69506fd33 *man/matpow.Rd 915ff3260a6359ff21eef5bc62c204da *man/sqrtm.Rd 2ce01bdc9fddbf5b7ca24ba416a6bdf2 *po/R-de.po 5a555b4c659a06af5c98056a920f12ef *po/R-expm.pot 4357e47bcc2633eb3727064d748bf9f1 *po/expm-de.po 360dd0e7e29e17c70b81b9c4e16e5127 *po/expm.pot 2356bfbc6cfb784c2eeb782d5d05f73f *po/fr.po 3d90f59b3248da1e70798e94456b5c99 *src/Makevars d962e154a1fa708ec850fb4c0726843c *src/R_NLS_locale.h 69f37c0b361b8eb425da8370bfe010b8 *src/R_dgebal.c f6d14afb2c4d4f8b581e9f8831b22dc0 *src/expm-eigen.c 0c200dfcb2b08aa9e69351514ddc11d1 *src/expm-eigen.h 6a225c8c9c4ae61748619deda2647e1a *src/expm.c 162972efae9261d1e02a0433beab812f *src/expm.h c0dd474c3e359526645e51a11f5b299f *src/init.c 21b9dff299ded0de07d111633bc7d06d *src/logm-eigen.c 1f6cfa33732ff53d58d2ff33e72fb142 *src/logm-eigen.h 8685b3faef183159c5044570e81b31b1 *src/matexp.f 87f9e2d01beee962c5ed0a16adcd12f3 *src/matexp_MH09.c c90f46855c308b750336974ba1071e70 *src/matpow.c 3d2decb5c522ff491ffa1118b0335b14 *src/matpow.h b85b0dbcc9fed3def6ff8231525935e3 *src/matrexp.f d4cda3837efeafa9bdf66bf5b51a4c1f *src/matrexpO.f 1a8c861e1c2c64ab0af2c7742aac4acc *src/mexp-common.f a22fd1e243d0d2e96802f551a4ff7f28 *tests/Frechet-test.R 1288143bff530d35a64f2b54b12b73dd *tests/bal-ex.R e2b8834d9fc7e5d6aa85fe9e2a729fbd *tests/ex.R 91f26dcd2bbd9c02b19dec6692e9b820 *tests/ex2.R 06ede83c4d2e0abee6fc8d3d13617f7a *tests/exact-ex.R a43d9bcf58d286dd0745b058b5b003ca *tests/expm-Cond.R ed2a4e750c0f271b198982795a272892 *tests/log+sqrt.R 041ae27011d67be12b0bf4cfadb27dc2 *tests/matpow-ex.R 61655a9c17ec4f2e874bc1ee2af64e96 *vignettes/expm.Rnw e1d639c199dadb136a99c08a9aed0dd7 *vignettes/expm.bib expm/inst/0000755000176200001440000000000014547731235012213 5ustar liggesusersexpm/inst/test-tools.R0000644000176200001440000001062714531337476014463 0ustar liggesusers#### Will be sourced by several R scripts in ../tests/ source(system.file("test-tools-1.R", package="Matrix"), keep.source=FALSE) expm.t.identity <- function(x, method, tol = .Machine$double.eps^0.5, check.attributes = FALSE, ...) { ## Purpose: Test the identity expm(A') = (expm(A))' ## ---------------------------------------------------------------------- ## Arguments: method, ... : arguments to expm() ## tol, check.attributes: arguments to all.equal() ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 23 Feb 2008, 17:26 ex <- expm::expm(x , method=method, ...) et <- expm::expm(t(x), method=method, ...) all.equal(t(ex), et, tolerance = tol, check.attributes = check.attributes) } ### This is similar to Matrix' example(spMatrix) : ##' @title random sparse matrix ##' @param nrow,ncol dimension ##' @param ncol ##' @param nnz number of non-zero entries ##' @param density ##' @param rand.x random number generator for 'x' slot ##' @return an nrow x ncol matrix ##' @author Martin Maechler, 14.-16. May 2007 rSpMatrix <- function(nrow, ncol = nrow, density, nnz = density*nrow*ncol, sparse = FALSE, rand.x = function(n) round(100 * rnorm(n))) { stopifnot((nnz <- as.integer(nnz)) >= 0, nrow >= 0, ncol >= 0, nnz <= nrow * ncol) xx <- rand.x(nnz) ## unfortunately, the two resulting matrices might *not* be identical: ## because the x's of repeated (i,j)'s will be *added* for sparse, but not dense: ## set.seed(11); m <- rSpMatrix(12, density = 1/10) ## set.seed(11); M <- rSpMatrix(12, density = 1/10, sparse=TRUE) if(sparse) spMatrix(nrow, ncol, i = sample(nrow, nnz, replace = TRUE), j = sample(ncol, nnz, replace = TRUE), x = xx) else { m <- matrix(0, nrow, ncol) m[cbind(i = sample(nrow, nnz, replace = TRUE), j = sample(ncol, nnz, replace = TRUE))] <- xx m } } zeroTrace <- function(m) { ## Make the {average} trace to 0 -- as it is inside expm(. "Ward77") ## This version also works for 'Matrices' stopifnot(length(dim(m)) == 2, is.numeric(dd <- diag(m))) diag(m) <- dd - mean(dd) m } uniqEntries <- function(m, diagS = FALSE) { ## Purpose: make the non-zero entries of matrix 'm' ``unique'' ## ---------------------------------------------------------------------- ## Arguments: ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 26 Feb 2008, 14:40 m[m > 0] <- seq_len(sum(m > 0)) m[m < 0] <- -seq_len(sum(m < 0)) if(diagS) diag(m) <- 10 * sign(diag(m)) m } ## This needs "Matrix" package rMat <- function(n, R_FUN = rnorm, rcondMin = 1.4 * n ^ -1.6226, iterMax = 100) { ## Purpose: random square matrix "not close to singular" ## ---------------------------------------------------------------------- ## Arguments: ## NOTE: needs Matrix::rcond() -- 2023-11: WHY? {it has more norm = "", but..} ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 19 Jan 2008 ## ##--> /u/maechler/R/MM/Pkg-ex/Matrix/rcondition-numb.R researches rcond( ) ## Result : ## -log[rcond] = log(Kappa) = 1.051 + 1.6226 * log(n) ## ================================================== ## 1/rcond = Kappa = exp(1.051 + 1.6226 * log(n)) ## = 2.8605 * n ^ 1.6226 ## ================================================== ## since we *search* a bit, take a factor ~ 4 higher rcond: ## 4 / 2.8605 ~ 1.4 --> default of rcondMin above stopifnot(require("Matrix")) # needs also as(*, ..) etc it <- 1 rcOpt <- 0 repeat { M <- matrix(R_FUN(n^2), n,n) if((rc <- Matrix::rcond(M)) >= rcondMin) break if(rc > rcOpt) { rcOpt <- rc M.Opt <- M } if((it <- it+1) > iterMax) { warning("No Matrix found with rcond() >= ",format(rcondMin), "\n Achieved rcond() = ", format(rcOpt),"\n") M <- M.Opt break } } M } doExtras <- interactive() || nzchar(Sys.getenv("R_EXPM_CHECK_EXTRA")) || identical("true", unname(Sys.getenv("R_PKG_CHECKING_doExtras"))) expm/inst/doc/0000755000176200001440000000000014547731256012763 5ustar liggesusersexpm/inst/doc/expm.Rnw0000644000176200001440000001052212165310624014406 0ustar liggesusers\documentclass{article} \usepackage{amsmath,url} \usepackage[round]{natbib} \usepackage[T1]{fontenc} \usepackage[english]{babel} %\usepackage{lucidabr} \usepackage[noae]{Sweave} %\VignetteIndexEntry{Using expm in packages} %\VignettePackage{expm} \title{Using \pkg{expm} in packages} \author{Christophe Dutang \\ ENSIMAG, Grenoble INP \\[3ex] Vincent Goulet \\ \'Ecole d'actuariat, Universit\'e Laval} \date{Jan. 2008 \ {\footnotesize (added note in June 2010)}} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\proglang}[1]{\textsf{#1}} \newcommand{\pkg}[1]{\textbf{#1}} \newcommand{\mat}[1]{\mathbf{#1}} \bibliographystyle{plainnat} \begin{document} \maketitle \section{Introduction} The \pkg{expm} package provides an \proglang{R} function \code{expm} to compute the matrix exponential of a real, square matrix. The matrix exponential of a matrix $\mat{A}$ is defined as \begin{align*} e^{\mat{A}} &= \mat{I} + \mat{A} + \frac{\mat{A}^2}{2!} + \dots \\ &= \sum_{k = 0}^\infty \frac{\mat{A}^k}{k!}. \end{align*} The actual computations are done in \proglang{C} by a function of the same name that is callable by other packages. Therefore, package authors can use these functions and avoid duplication of efforts. \section{Description of the functions} The \proglang{R} function \texttt{expm} takes as argument a real, square matrix and returns its exponential. Dimension names are preserved: <>= library(expm) m <- matrix(c(4, 1, 1, 2, 4, 1, 0, 1, 4), 3, 3) expm(m) dimnames(m) <- list(letters[1:3], LETTERS[1:3]) m expm(m) @ \bigskip %% manual centerig of "overlapping" box \hspace*{-.12\textwidth}% .08 = .16 / 2 \fbox{\begin{minipage}{1.16\textwidth}%% wider than the text! Note that the remainder of this text \textbf{mainly} relates to \code{expm(., method = "Ward77")}, i.e., the method of \cite{Ward:77} which is no longer the default method, as e.g., \code{method = "Higham08"} has found to be (``uniformly'') superior, see \cite{Higham:2008}. \end{minipage}} \bigskip The actual computational work is done in \proglang{C} by a routine defined as \begin{verbatim} void expm(double *x, int n, double *z) \end{verbatim} where \code{x} is the vector underlying the \proglang{R} matrix and \code{n} is the number of lines (or columns) of the matrix. The matrix exponential is returned in \code{z}. The routine uses the algorithm of \cite{Ward:77} based on diagonal Pad\'e table approximations in conjunction with three step preconditioning. The Pad\'e approximation to $e^{\mat{A}}$ is \begin{displaymath} e^{\mat{A}} \approx R(\mat{A}), \end{displaymath} with \begin{align*} R_{pq} (\mat{A}) &= (D_{pq}(\mat{A}))^{-1} N_{pq}(\mat{A}) \\ \intertext{where} D_{pq}(\mat{A}) &= \sum_{j=1}^p \frac{(p+q-j)! p!}{ (p+q)!j!(p-j)!}\, \mat{A}^j \\ \intertext{and} N_{pq}(\mat{A}) &= \sum_{j=1}^q \frac{(p+q-j)! q!}{ (p+q)!j!(q-j)!}\, \mat{A}^j. \end{align*} See \cite{MolerVanLoan:78} for an exhaustive treatment of the subject. The \proglang{C} routine is based on a translation made by \cite{Matrix} of the implementation of the corresponding Octave function \citep{octave}. \section{Calling the functions from other packages} Package authors can use facilities from \pkg{expm} in two (possibly simultaneous) ways: \begin{enumerate} \item call the \proglang{R} level function \code{expm} in \proglang{R} code; \item if matrix exponential calculations are needed in \proglang{C}, call the routine \code{expm}. \end{enumerate} Using \proglang{R} level function \code{expm} in a package simply requires the following two import directives: \begin{verbatim} Imports: expm \end{verbatim} in file \code{DESCRIPTION} and \begin{verbatim} import(expm) \end{verbatim} in file \code{NAMESPACE}. Accessing the \proglang{C} level routine further requires to prototype \code{expm} and to retrieve its pointer in the package initialization function \code{R\_init\_\textit{pkg}}, where \code{\textit{pkg}} is the name of the package: \begin{verbatim} void (*expm)(double *x, int n, double *z); void R_init_pkg(DllInfo *dll) { expm = (void (*) (double, int, double)) \ R_GetCCallable("expm", "expm"); } \end{verbatim} The definitive reference for these matters remains the \emph{Writing R Extensions} manual. \bibliography{expm} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% coding: utf-8 %%% End: expm/inst/doc/expm.pdf0000644000176200001440000016141714547731256014441 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3364 /Filter /FlateDecode /N 60 /First 482 >> stream xkStZ[;!v1tclj]ʶ|(8svA#0 %#cHJ4a< ι&LaSD4% F ),zC4Љ%RDSn`1D+h:&:>%)K?RB%HR45 &'i"81 !a7A&&"%LL$%6O @a!R @`Rb"(H 6 c%qZ@T  p}xD,SPeH3`БTF0,,Le#%#6d?B|1-FQ$gۼׇ$;P?ݒ7oly>Zhw)?2;Jj7+Ḫ̌78Ϯ9t98;&wrQ3?5 ]q]߀:q}ݯm9]EIOb={QM3Fsha1| #0{O#qgضj ;B MsM~Iۣ2_?_8H8ٛg$tkZ˂b^.vFsb}7wnǣ Jvr\+q3_׋;dJCqտAAhsXwϭrԙBzxw5HE2JI&E%&I [þ?'Y.~#V" bȐK>/[Im,, 4҆#6nڏDݺtW@,G4O,H~&kadDeoR&\[b /+\,j P8T/WW &ވ0=B0eh=S^ݯC_{JAz2ոhPJȡFrm]@^X;Ḋ$I]jP.5~Dtw=6/FmV2m5+m%;nƏ<9H89I'g$GAJgx/wMp :@xN@x΀%y1Nx- LYgk#: .8dXReX0w !nqw_)բcZS{yCəJן',M2/O,BaF_S5{& ORYܾtZ$jUQ8>uES촲OWЧ~^ wG'M5H(/1dTzjU8Q0Zb0Kb@xwCi4 oɆ$Q-! Mla| Ve5Z)چ[amDɩ[z2廋2FGqCś6K/yic\WMwuui+Gu`"s٭@ 'Nh ϣrz|4έB)0%_Őv)?GԹ-^d+RUjqzlWCbh-\♅pȴʹKcZ2|ُ;'(8^f0-O%L辙6Ƞ'xa:i/*`ARZ lۺt)C#3ͺʴ %Aon}:7 Ѷu_wpx_!5ad`奡K14dtB)NKq)8Y(/RԳ8~_$mӳ7Nҿ]3:tZC+ d=bPXk;d(b[UnѤ}EX}x{~j"N{FW|b"t [ggdK%lk.[b5/FUګ>m=&l<ǃON{4X=&M a G0r]Q t <B: ԼtaZ%}PI4䥦#aHUќ) ?VQ?1Wt[n¨'&88~zD?:%ocYh uck]яpaKmp?ϗI20m > 3W2 L܋g Zpޑ/{ n[a"ltFX%E¸e}_}/^}@(6xm֥a"ie]Hʈii_}?Ly̭_w֘L2:}%#JrSuPݏ'gN)(ӂܷrB8_L@~RwS| [QUh!HQFc\Ez=ՉOGW\&[mVK!Vq Wo {÷1 } t*l㤷m#h(~R{$ Mo^(tnL`@wb˴@rйFȢ[v)> U/E4#P~4<a%Kw/)\+Jli^Tה.@O++W0-(pi-X*uL*> stream 2024-01-11T10:19:42+01:00 2024-01-11T10:19:42+01:00 TeX Untitled endstream endobj 63 0 obj << /Filter /FlateDecode /Length 2089 >> stream xXݎ+UF1il1ܢ"^wW~֔&G[;3Cծ !g~眏TT%IUN>M(-Ŧ|w WJ2L *$ҡdJ\1L./մ*+%-9#4Z CQڔk qD4o?ԧC\L,hȲIOYDQrfli+fҗ޻TxǺ 6v?sH %mY/-h Arަ&qF3RIľ?-J>JWVFzy6݇l^ŤMAjLRyӱ@ vxzw&(D `TlKԹ|Po;3_ Zn&?i  ;)mվ3Ae'J)}ښu.#(bGq [c *d1]s*T%wϓ }6q?!1d;ӈ2Qcߝ˳Aѡ0ݻS쟗L\#XN}>%_ KQ%!cW| 7?I' fHJf=y$By9>)k0}?0 @ֺҡ8sp S S:'@ ԅJ`g(N2_C5 Ŧ% .r=^/Rw钮zb`s θ3i@1]5C\In U#{EP vEFUKPfu3X5X}2 Hn"<3 SܽďgF0ƴF;?y쏤R>Δ'4D?; =כ9==Q:aS.X4v1е "N|\IN`iG##msko.e5ݮֹD]k7Rq,=׳}ǩo'?_1VL43qvHaݭTdby_ubV0Jnڵy'C by/CREuDz3ҙF;VW3z| &/>ҥ#ǘ'1&ݺ҉t5no?J>¨ybg©#ԕ(%%1bv[BbuHQ N+<3rhy v;O=,t@:žiUENôy̎OgF֫mqS? vq>Hy%WB_t$tvuw3>> stream xMmLSWo)\2v;ݗ-s.9 :Xy-pY/ܾB HA.@NE|8-jt<<,< xI|6txrYEh>1;hXhEٗ/)Hðd,Kž`qV,K>"1aa__^!}[ a*M" x\?u%tDb0y+9@rPi8TJ=ma ܞY-64¥g5]B2M.|`S kb*%&/ɠa6Q=VHUaR]0Xm99Hy?SOh C#l'g~k]y+`Ny`';և>"r3wNOy=PA?-`b\jVb%[\ߠU:h# >y*wDEz<j|c ^RI;*t[tFnsb5g:O *߉V.>}\##Q_6 ǣ2Thʠ J'^L⌀۽wVO^ yi^X'R6xTFŞ`i%2* /u)vi  8L! {ⴸF{AY.Q͉tA\^UI[Tmm-Λ_nb7s "@ /j%&͸ uzB+{RPnhLUX+j%/罌'QyF].jSp㭸Eh i+ڮ1&Mj] !d9YtX  4{cC6TQR*َvZ"Ds(UdrE&I7 uNWoAc-D= I {mwZř[^z@A2uZP_v448%m$*y)u:X+6LA\pw])D\Ν=G<6l\^5Y?MO_k$˶_kBv>rS/ƗgC[{H5V`LT,hͲ-mnBߪ(#3z~YnaQKp}Aag/{A.&JPRf:Ahۛ.WAMvIpqRS|P}p`,opLoB+ht8Ã##S rH^CKreR91y_л#7"<|A H1bhAۈ@$j X.^ :ي,~Q|Wёñendstream endobj 65 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 607 >> stream xmQ_HSam~Xv[nTDC#%HsP#iEYEC= ߥ/X.zp^΁s0i8% ԘAY/^K.ur'(EgYImA^+(>D&by801HOZ?q}L1CD~'^%q=JU.85wo瀞gsieNE>^˴P1>+LWY*dl7uyF4**jϓ>@d~E݂PWUf9ګPc\ 4vu͠aK=#P Hzk'rKn:slr 1D0 ckKZ|wpg=i,zz4c{\B/sq[O͖:RyIm3Έg>BVf Qmv䍨qRWW(qy26m"~jsH+͋ Y< /:mwDG胶GaXI |AkIMMInt5|96xz .{@`X Mڞt}BAendstream endobj 66 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4485 >> stream xXyTTW{5. j1zC'6[҉1vkT " PRE+jb)()d7 BDbctdҚ嘶oї-szf9ϜũW~~.!. `ܦΝ7g0q÷Ä@T2Cޞ|7c,uiڲ3Vff!s5kwKذgMɑgn֝98zn7{m~Ep3Yn {[s\n&"{aM.qrbwTqС6 (Ct\x>5n8y&<>?LL99fO?G?Mʐĉ XC7ș$RnHW:lKo-aOAKG `U\T>Ԟiϰg5"PcV!M*#6o&ʄLS~EAΥs.#oU$BWcCh5BuVZn]]ܦ[w39 !" f5|a] }K$Zmoi3ڝȶKa2,'d"*}}$`7CXТJTYʻ~{wΑ!Pp@+PDfF#[B*X-1=ii %c ?_.YH|84jkGr!MWʒZ3kv{yq,wjjVv߾r_:/2ns<䡓k@-he6<#[PK~7UkA0y'42HD$Wt P1vݏi76H͇%0 3s3]Շnm^M'SLї,O_AF/|HjdH0Vgֱ{|s=cBCF%?E+4nmҏNWfTe]zr0|IԡM}3&\V\ʎ>.cNco# j ?vʬ{鄗h//{zAAfѧ&s,ت tiؘH}ul\;ͯ)Di˙>ˬDG{?o6Xu֨ !2Ķ]){n]'Ox 餚W'-,Wy[..VZ <9^Pj7f_H)B(.sTKH_pfH8r@bg xZ+*զ*Dÿa Z.[j֡+*~TwJn~gؐ?>>NfjPsEFTiذFs0S92:Ln&5>`eCt@ŭaA2$iY Çk=65&Kŷ 6v6dmd),r= D]77_?"I^*]}:C K'c# 6,o6}4w^I$7bޥ$-,XLD3`)' ,X $Xuf`e/ L*{U%Y:sVtX_Cc]*>m0 ˯HHHĬJR(x^gUFY]/}y.H5 ϒЍ9U>H2CD6%|Uv!TtaT42Kvp>7w[׷5;iE4y~1i[rNX+ŢoyW|7o\SLu>K^Y_@)ϐgLLתzȟ :DZNc 32-:{}$hfөevY@mg@O,_4a;2endstream endobj 67 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1668 >> stream xUTkLTg>0( Ds^KJ( [f :s{anʭ\R; bbkؐ5ݺ)tm#qHw__}y1~L& 3zMt hS C%†>^Mȵ%gel;+#~a>bv1 >&labmL,eB 3ies WL"/W_v"{o g¸M|F qZ.?p÷lJ.Iy1e ""hHVmPtK֝7ߙ qQ8<ͤ&K^S_+,]KG,a+pNHt^)&(aAendstream endobj 68 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2902 >> stream xm{XTu00砆q°1Զ-3-lV^W@I&0A;0\ rIMԼTfffnl,c7Sg{/~% #H܃3HĿ&tqRjz| O|tN`cRS3E)cbWmܔ4f9άdf0AL0¬fa2Lȼż,b^d30Ke'3o2m LrwNZ'EW+=V%.)C /v4c1Ʈ~Wxuـo~f#=rE#_lk)OU@]Ɵ H}bq@jz])}fr nD*)rʰ9)r2.gַGǟVAs{~H9tyv0V"w8򷛚 ~P5=Y|-edfPxqcD//K5u_YY~m$.b]H4!+sdG(+G|%g75隦|?l?O:$%Ð +;p:cƶpC0q+, Y]a&DYf ԋ񀼏w\Kɳtٍ | | qmMm#ȥ :t'LCf[ogY9w$T7Cb-[z2@h&2Ũ0w㺃"4&YѸUtUFXj!+r+r-S6agS[`/5])k4P\~iJ$,J+(7U jc r8[< ^%;2AxLY+YIJk {]>{Yǰҫ SQ ؎X=;A}Jm7$8g]sТ5dp&nK](; ጥ8_)K4D#cWhMl[Sf(ْw6,[\t|٠"\?9wː]Sq݉N\( .vnatKΤ8%]wDg:fɭ&KcJq#KƒUJ2%g_!e ڎ ƬbsS33J, Foq oɲZ;ZL3%k—OQ#woDAr뤳 S${"q̖o)P Kn)TZnIXQ+[ +TƆOy pg6>s6TU՜Yc(e`+.X.m-pO{ݮԠ;Nlm-+kvFay.Ip֬m圅86#b{8]\th}hzw`BЯՀZGa4vݥkﳗPc.TUK8RB lO肮̺' fyvRM)N 9WY=Df%R!I^@ҷ6A_iJ\d,.U4rCXZC=>Y\xȲwk['g;sq,>Aϣc|(so:t{AUWtf!h m}SkXem촅): RAgDX/[=i;/b^O`<=  f[X^g6"ɳB to+Y}֞ۥ}yVMlimӗk52vڶіܒ"hZ-@QuqRؐkVόnW'rv쮮:nɎ }W-Z3 Fܜk /C5>WVv(/ܚg5V Əp)h"9wcEygDc!6Af}T"-\,BهsdԠϹXT뫩niU,k Tq"RރZ9>XoIO]ܞ(e. Γ}ͻwjǃX|jZ2#LscV-ڪ00(PiӍ9;V֪#nvTYEr-ݒ9?̒ҋoދ kL3<߼t8&9w6_'x|1!s9VePZX2r:śgi4TrP"!8\&O(d *&jgVeg3%+vq!EqTnw#  ؒ濱tIAa5m)r٬cbd%!< }]6?p9L&}GݴDCd23B,႞lBGf{6(7W5]bO 5"$cFƷm޻ղ+-AHksg҃endstream endobj 69 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7729 >> stream xYyxSUڿmiE@1Ӱx/(KQAdRU@Rm%M%;4{ӤkҤ[P MvW( (8x|љyg}ڇ67&MDEE]:{Iҋ %uibAпsMq8 7kz挬ٳrrϑ̕n4??9`󂔅[mݶ$uiڲ+_+6q냞5lد^|iPA,$"Ob)XN"V+U b51CM"k7ql"H$^$"㉹}̱O98~r$YE~K?2_~~?0tG>g`Р<=7!{ǿ}u*.,C! -d'&>J';aL_5oO:5bSO]{T4ѿG{pd4'06ZAmu{KMV7( J9%9)@BHh9P:grrXQ,5TVQ+âc#Q I7KdB.__T+ڦKKy<^z,~F8}ver<^Sd&OPF672ܔe^O%3Kdkc,5ǐIXq2DNt\A=`QekD2HX <#Ԕlk<dx ԑOЊgάgiO܎>4xU@I5$H*36P{PYb-ÑذL˰e0#D)ci9=ekK3}0xQǰ;1 Y[-dJ.M&0)(;v0A)&{Z# GUpA`@)ӂT]-k Ӂ 2*uEz99+7jڤmF]37 .l:lE'$1\vmV`wͰy8L#"aƚ"j+7 3ܼtP5ݼu>olm~gGXszvTӘA84+4vvpv|Zc!|͕GT>Qd/jį\YrMiS@T\)~לDYk/ftuN4X/U卪P9Yy[@3`V*vySv5ИzQ BEAU'(u'pRm@< ni:8^uZ(D{|mYLHVhHהo'!p{Աn F#lK]":Nv7&k_Nsdj+܊lgH0{ͲYc'?^RSD5> &+4o34j4F&rL`cE>GVS l6Vҷ3 H*kS S|s t*v|O+׶eB\'+Ĝ a:sNp^{CGrHԻ˱f8Fk J̼Ey9&I!ȢT]{%/ GPym\;nTN]+Sȵh&; gT) >at ⴁve:Ɲabx}$iLۿPS&Y`X"nDW<..ˊm5ҫppY᪰WZ~ONץ{|gB53 QS(3rJUg%sU !Nqk@}iu'j g "z|0Q*w9p!6Q?UI r2|wrk:[Ŋ1[rΰ1-K38I4`??K ~&E[-2|Ҿg ޽<_LΠI$ZU kqXwAye&K^>ar@5eZwzfl\LDM{^)a4T9 Xn&>yᔽY. ;N0o_QbpD.<{Aǣ(oܡ'35:]PVN'8QicC]RG ׯ\ tv]>9e:w})m|6?Ub_!zc?E6e4Bv$ǁqwn0糱n uNfPQ^ E ʩ.VUmJ;y7 4ZxO܁秃ɿ8an)7,"l(=}ŃaUX99S`5l[) ի~Ihc \r 4=8Wg||$ɵtzMH7tnޅVK 8Vah-^OYU[-E;X+d5u:-SޢR_y8-HCT4.Upe ʲ4oFuc38_: j@M2@2" s|2c iθƋ*Q%y?thMIoK4 cX`&hȶZa1 -flC-fYhj:ƹ|ﰟh԰?{rTs 2w.c:ߺRXH+ ym9mW\+/\嬶Uu\laqX AxXm;TL]=`vz>~MwօxPkXǠFr[n!~YH?r BT=$3$ ,{h2$ܕPu,t6Rμs}񳵝73 BSM+C`CW4r*3f<豸 &F̒kh\jӮ ojD}o%__ˏgeB 6%f7$Kvʤ(k]ezv%^`zx-MF\$ȷ|jn\,Q5R?S rmEKOw=}(\*,Ũt'X$^c^ 8ՃT6S%'ʱph 'r6vq¾qƖmT,J|[^W +ݓo";v0HYtxe`Z0=P@AK 2UaBW0X n=*6 1yxYoe^eQڌl1!",3^ f+2lbF``T?MR䞓Y K> #|G/HieyAsl%7`iL4Gaڙ.QRٻj4 [$z0zy ķ+: a/uW0Wzu[dcGVD5I+OR6R^EB|b,M^c5_߆|lvJk#3͟/Hi}ƻ˯:笣ܚaJegw '#@ L͢ d0H^wl0,H$Qo}b5dk'[' Z| ->؋B,5ŜJ:cVU.:r"zb!ڝͷjmZ J` }g` 4L*q- ޕ[7Ikҩ%yK,DI|u*[UԢڡlM`GځCBPGnUlU@MSeJSșJC)"mlrl=">"g_iK G2>j:';7/O''8XD3ܯ׀wQp%u!3Uʹ 7?fs88f [T Hlaz evz }@ڒROn;&/D+SR 5y ΰ4L\8 gy@eQqpن Vø;ֲUthgpTIKq2p˟J##0= "7yfc쥆F'ɩUU\K /DF ·~9/x`n>cAJȋAFYt>C_lA KzDn}؊l潘ϻ&P2Vnӑ@r8w>g̥36N~{6 2 t1R T%k,pj_+O}G4U*<&V,Uטp2uv_ݎ+*܌ڼrͬV\.İxH.`JB::l6 )'`ZQ5OA ׀58n"m[P j|-.5H/U(@4p59g#vCau<~yL"8r8J؁͡p&y?֒^?sc05hPKMHCP_)-8wN8)?a2_&?bN Bf" 8Y9V]n d}@\eVTd mۙI#-@ɦ U5T8?[T[W/3i/F$f_ac?[ u~L'<[N tp#/mٹG`EG~Ao$pgTC/ }%unh)YYS`)պ56C/Wk43N]xhy)(0օLoJ9&:nuk+,Dq. K<7u~öhniׅyYKlK&ȠFh8{]Lc c|m8`oS)Nį\m=Hѩ,*(5N.,G4Es' vOxc\%s%o-xZm93٩:j&ɜL3fbIB*1}S˜Å%kuZ^ozWEBc0"Gˎd%ߒ2ENE4vCPF{okddy^ `x6;"&ϫɲ1:Nr~`]9$| {Tp]|px̔6NT7vܔ^8׷fE#!i}_W+ʼF_M`iMQ!" FA3(MRw/Q_QhPD $RG=J?ڿ/A;endstream endobj 70 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1221 >> stream xu{LWO)ODti1Q.MLDE漴xPJKbo\ eARIP[6?tl q3q&vN9qNH&HZ^K 0_ `Q{;3gey \n9-5r6e _jmrv ; = 85">*)]mPcsy\J\˿'YLެIlmge)W3]mTblͺY=]= ߝIqh.O/F9:Ϫ9yQKUUc玊8~n3*/\Qy/ _qb/ lw"} 6:Ԣ+rG3U4TTLܵ+zW vyðy;wgQN/wEwρ^L3ǯPS]z/ L'' (+0WRNG #䒏mk` si W֞!{G`?Ti>( TB_UzMŻ]Y#A B|࣐Hg&&vB { r.%4{MvWޞΠ_W`6=S$pO&efzL{˄5͜r|/AxH~>/Myc `NkҞFÉmy)}H^Ϙoa5,)vŲ߈Ӳ| 80*_řRO9F[*-eI R[ER|Eo}cFw ^ι2v8۽'kK\u$6Z%KB<{Wendstream endobj 71 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 304 >> stream x% SFSS1000va  CR$3qM@~vt|t{rfzac/9;=3¶|rPNLYLNES]vKJ%Au[ы'}}}#ԋ뇰2R`aUxf~dd ? endstream endobj 72 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7591 >> stream xzxTU s9 DA(Ai iLdKI "*ٱ~=߻P>$Ok}מ}999̛ȨQfBL\0Ap࠽ sUNTdamQT bItfrs+_[1O<9αO==X#xQcq'1N&"w<>%~eb>HBL"'F Hb 1("!/ӈljtb1C[|BCB6%7qxFb,1XD QBBL''(bW΄S}ٜbξ~I"T -} 4m7NMA>xͻ&271 Jm6/@XǐUCchBUW;myb_gpaǝ? )S*O3wHM ZhR#4-v-¦@01⪀PoF~qy0DH9ZP7&*@2 + \co+}+Fnk.\ cJp9= 3Je4́co9M0lByo9t 3SO%qRJ=(=dJj8Kqp *&=זHk!ᓥ¾dT৪ _f NÒtWP*ᷯ2݂K J,7Jfju`Q89$?dizg?<~`DHgJP@@߶/ f\:D;,7RL;]SZf5) ?J8{s53]h' h@9 ߩﴟjA7 8,N?xgwOzg=@>Zx̕Mt'7732`u֒A84;,z>h=}S WE--D7_#wὐ:wL7X4&8x?GBut%& G? x?~Cu2v)I:\v_jÅ?7/%7o4R<I4DV4C`xnsO5[_w>tn#E&`1]21.I^@q6 J*qTT'Yfۅ[ T! _D9+uIqC!yF-G nI% .ěݴ)bQK"۸݅<1>C:TeP)`]3bQ:<\V~A%ɌL F%$gQShaOSh9{i0)TEY8_ߋ/:ad EFEaэT:|ng(=d^hd21-NY_ G,Žc1m@" R䗻`x˴,%oS-,6L8;t>\`S?:~hܥ!vtڼkNfjEWa#NS mP5&vM½cQ? xC03S/ m3,LV WV4d|1eҢ:JնtΦ^t273MxѸT27F`ĤKiT2_&Msk`*|$:K%xs{cm1u_괵b[޼:f FP ;r˱4$ɁG0<$Ej4RI7(H'(?8.@2FS%UŒ ;YcXDO]Jz n*; Wcl;v%%Ԫe#Xc=Γ8O0OJ4+U;1U:09c!F,o"6L-)հW@ WB\~A/ylM+֎ R)PiE+ۖ[vVJ|∼)[ϑ)c}d~uۃJIfǸWLJb쓘",~kQsL#G ujҫ4rLBј&P9&_0և6"J. hXLWٛ t_#x_ܔPܽ$4YSj$W2*6RAض1O{j|uv1-yO]?}P-d<,L(&{qM BVrdc9ñWhBx .X8"(m%OY Hu v:{;&ao*%H 1EL!}au}T][:)8H&e@+H'dcyz W] gb 7u84UG|M9fF:AH4mncDU^9I*ŝVpppE"_cZ7vv@ӞӼR:=ױ-nv˾m-k>#8}Sd co$)o匜T+n-ĭ.V󆼁u?NKxK:⺀#\x3? )01Δ+ayFO2N ZV\2VMzx1>]FIFL׈U*Y]Aontba~#]/'Z[SiHs."7+^ۛʈݻ}Zeof WEF#_hkι::P6$rnI[*]ޝr' ZN5:9CR]3* Щ@0d%P6*Ȋ DSEfYgэUEGGG@]il,NVFtoQ<O>>~UWjZQ~dBc{Tˢ*}7攵m>;:F?ƃk8QeE|vփ @9 豦v_S)kx̓J*}LLBB%8S©LS&9(N89˺"zV ГfM}q3' 58oC|뛿ˢؕԾ%XJs$.yp~ӂ+CDԛކ@W`CaOĸF0DyY񺲊~4@)RH}Y`Zgy X(S^!^#m!v22p&1g;e[Uox GP!h#@@}C ;= B'enYE*ױ)0c,m=, 8qL| lY_{?~ϧMkB>rt#WeM= E0lRDYu%+ G<½/5@-YݸEdjnHj7J[V͘6<7Jd,F|*wZkpp$^TY%k6gʘ) [O\IҽdI&垤j"xĽyJ»JdSL1[mGƯnS|Ý(}yW"Ӌn2ɔ+|8zD6 -x-$JJ ;dȟo>g~?,_"Ld\ZQXu+gOù̉]8]W|ݯ88kU`@:Gxnc;evypf`fxw X lv:gsCS'Oo8ަQOlJ|R9\)CoZ *fMd-~@xiŒL]A IO̦tb9QO^L:s;>٩xއgO7//vE[TzC=rMTs"~rRL0z 6p?}蹋+a^ G6cd{ JOS̄lFul~q`:K23 H& ƣRZ&bb3#-empaHA{@xJC@֩xXG8{zж4\[ K>/"L0]8a%xF$'?aN/y86p֓C{p:r$;.9&MAc^'gܬ&O $;ݵѲY@MxnQ+a_-?s{?4@Oč2e j/,--s, +ݺ%y(s~>~ LIiTq4 ;^RJZO9;e]C]YNP OO: Lfô8gZ gpJ8MBĽQ;?i&ݛi%whUo釚'OZ691ͳCsmFDg&Jrb8(z/Az{_Eoi[ʢ}GWmq=Ep0 C`U(r 2b]U{_r+j֔]&M̄wzFpOCxi fhe@Gɿ#qLE|6$q H3>Wi@RIbM`$ GG/4C|1s377siuBG7<*h8-\]ps^t4 Gn- /+a:̍bfEf>x U^@ׇu߇3݌ *(hEPy=;?8l?R|?O].\ъGD-UȃڈkS6!TVQV( j-ݤPhG(-J(u(xQ6LiC0t!@'Hk#5!6i "+^D4:WHF~:LaJUjݬj1PZ.p,Ҭ`jłc:1K27lE2Z)ޭ Z`K2*ppL{\_L(o\P.u:X--^(Ϡ.lr%/~хP0 Afa>,+d66Z 5 ,WZ?%@MMGQb Z2Epo)wrSf!2Q3 h ~J oF0o df.ma5JDQC籃3UlD_ 5(DŏJe¨*ȔՕFw~_[߅ n,&Q_2] ^t4FfX z;z13N?~ y#o n0L>b|m2 HKa'ai _Wr=<$x')TDq;5ٽYcZJ3Fh*Em"d-]h.MpT]-!ޏL1l%|92Ղ-m+B]_x1alDpiÔPA3țp.K*-7"D&!qNg*˖j 5NƮ)p fgkFs:'s{zHGw|Ic)F9U1Q[s"xᦖ9n,u}OÕ׬.y@A]jF4v|]TʍUfxXRU^̢C'3 4.Иt<8_Ttn8,Ӽ ^>>DLIZ-x%N0F8hͪ/27.y?δ ԆM7s,^Pϭ2A)mҠ>7HWI_tgqχc\* 4%-UQ9}AĎ$.<2m͜CC/=jD#DDkM endstream endobj 73 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 262 >> stream xcd`ab`dddwu041%2Âw 0'3##K;|?v|-?1i"ڰ;wϟw5e1l{v}{C^]&3z}j:@}uo~ܽP٢~b]ã{׏'Wb0Pj[Rfw,jv'u|g7[ ;miXp20Zpendstream endobj 74 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1430 >> stream xmklUgض PHfbHS `* -jݖv+זdglwcвn_RG!  /!<&bR[gnr=/IM"Hr5 ߎmgO?D$ƹg'|^$bkj%fh .!MD*A, V:b:1MIH'I~-nwx1[fd[h$%rp@72a8:zn88! jIי(D5ӳwiԎ}y *4ʂ R&/^A\trh@%WUyw[wxre.Sa65u\"?4D(9 -Impe@U)]{Ae]<Oxvj i\,γl=uW{D!Lxtk ǸMÓ]޲t<(P  A*IeU^n`]VcN.?i-TN\W 3|-~5[,L3S }5=]v.`Vo_ GbNBm3.bLMQL?'?  mx-Z(|6VV3o,ؔK6Kg%Jy 5kʩ*\¦،|5&k&"A܂CrGr 8 wU>SF KhD=*U#pM> stream xcd`ab`dddsu0$i aaa[h RWt gh h*l f޿{{ {ywXtO+;/l~+}d] ~~d6>9.< Lendstream endobj 76 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 585 >> stream xM_HSqw۽^enqћiH )J>a46fGDw%R-E0JʈɹD9|A8*.;6_[,ΘW˜,1#,9ָ\&#OlTj:iR'k]@lv v\qw"'dSfm)ܟ>fL.I1PU/k O ,E}Nv*kV!-CT[xXь# Rŕd _!]+Q sd^9;b_fٯQK ͇A B0tƚ?>A:7^+tBX -uò>"qqL Qy<˔dB,*0,b:e*MO.JЉ4P(^"'TO24y5> stream xBCMR7w,  H=012Fj?ts~*~ssr)pt|(|trsw~]lM;|CC|||]Nw}Ƌ݋Ջԋך ˠjQUC4AA~Lw0Guc͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0 7 D/endstream endobj 78 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 268 >> stream xCMSY7M   infinity1*v8|vtz{ssrr ٧2V{eNKT1! Mzp_z‹ 5*Vgf0++=@/.K+9`cJ4&$D?fkKendstream endobj 79 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 234 >> stream xcd`ab`dddwu041e~uȰfwv0wL+tUy`qinnbIf~^JfqANb%cc;##K׏>%@ɰ|(  k[oܲ6!޳ɽ}${ZI)(cwgS:6?|Z+%lyeV]c ?|nnl=WO2\Yendstream endobj 80 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 757 >> stream x]KLagh1?J 1Q5,\qFQ$ 0 hE_L[*6Di Xb0 )s хF&s&,ٜ\$I_Yyp+Bi@ /G_3X-b&* 0%ZpO+Ԛ -iRxYRO;nd%gR06GŁ `8)iy>Za=ޘv\7[^YclghvX Lp6w/@ b*Ls)@ɰqrvK/ 7-@S4ZUѝuu'O* W?yQBN !el6[)` @zuIݲEDž!mU8Wa7Jg`R7T@0AX4X]S Й#xЫ}.yV!](˅:sigdK:5sv򚪣`G)%徛G7/GT".1 %"/yT?uDTm坲 pkvr6ޗJ鯱4n%񇷋?4rAQPqXNxl1gp^R7~p%2;tIמP >q.w~;QYQ6If3Aho Ȓ辑\m?AZZYVkw/#{endstream endobj 81 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4196 >> stream xWytTU~!e%ei{N.8AD6"hel$Ծo־R -Q1 .qTl9t8>3 3STNTw}WBGL^^ٳg?TJ8i+R4y&rMߵ.kulm[!^㙝kzd;x{g?ZMfRZjzZBKmR˨zKVQb DjuBM)>u=u+Q/<=qҚҿO9 [{6'3q$$勞'u9SzMm[9>gqu,TylIM@*`BFARZa,/RV& ^RH2J=O".;iZ$)#*-"&5ryX d개ui:@mqr:NYC6-+FE]&YH%lZ^̇y d(VSSW Ɛ'%ep.+Wx GEu!Mܩk_ŭj؍c_VgI1GR/oǔM 9#PP 2PU Hj$nTNJS^hCBo}p7[y[,tXj-6]/mJ7d!yOoIN)+E՛zU-1lU+t7$x| ^]?2H:&-@IIkm(_pidXDIyW_g/ybz]sq7@L <@{arZS4kwDX˸ 'V^>NZ{|2go)#mi6&G4ĕpThO!mZ2hb_4#32+fU^?K4DlΘ+}T,tЖV]Ҥ7 L6܀`UoimqdZ!݆lתt%_޳x^+"ZU ;yD Snmkg%= $O2G$7ǝʺ(Agp:"WfdVZeBF xJ],I΍!m}>M[4zb^c mLaNR<7+=ڑf v#% i舏k1YXa>#K_%ZD Gfτ4p GZe݋-6[{耆Ԇ;%xBƓugXzD{ 3(9fK]GK y%ڄ.UlӘn r*[T4.KKNtydCZbRWwnKRb> ,JBgLz'؁ MO 7޸zy e)m9{ޟ>c5wbRFCH IvA-H4ZZZln맽`۽F}ݍc )o x0i|0 Zo+.ݾbVIm)+,<6()>]{aASXA0œ:,|'!YH= B4ܽNLӚ݀:2JnvA㉧"ϙ "ڀ6_8؂7翡iR0D ovi.2R}UsS ݄ rǃ&==%>myݝߠK|.sWLqqMXa!ux+%Eߐ!z#6i*b?yj`6{yJ3#Rq;t<_|$τ6c= ^m%j<[,a\1g*''(ޢ,q3z,bd7ub4W*/GhuuQ RJqSkVSTXª /_ nf`GSsm zq 7?D{W[˸E@e+ȯg^&> ./K$p1#G*1UW3]5H ɢ~ QcLd(/2J^7}_'/KbC qq3185V#<~n|qܶ`5} k?O'1?NrRorHAT,pٝdiKubbX%~{*p,Ar%:"θ\ ΀+0%F@7o_gZ>`wd +\}JC?x9w=wO3m#)U;`"+" !?ӸU_Ԧ zQPё ᯠ EW'oꔴSxSF⧾+GNA_zԋiުC:ؚResTI/Iz.S@^AiVLUG2{5CYHO_]1G^na:=?9#/JÜ4Qkh <<+> stream xZ]GYOH/5(CB a"ʬ4kio==]ۘTR~ؙV{nO_y!W_^DlVgK5Egi )WHeg HSp?4[ ^hK!`1Q<|:;{}.& 8&FQ׏k9X|~n/5F[)<|0"KD;2&݈(zxk-h LǃJ2U8k (\p\Ma6p^3D4ٽВuޖ rRw2s \f߀ .lMa|;3Bt W/-kxa:R]n @=*? i\ /m٭}1ȀCvdM%^9p#W,^:B8*InT"u$Gѳm\kzX/ڹG] TO hS9JnfLmuN/~lM?lٗ /i%9x[8fE$ΈUjzU8&o5yyjZ+&:/zTV:e]1NGƲϻG\\[MZJ{I(85rIT%FVQ+9/珏y߂*iO)(v8^04z$١s;hIEK!Q1n5B; +{ Nȹ6zvvYe|,+WͱK lUoMl]jV-oEYgl9xU=x]-Jˍgv*+<7NRyl_M?9 :O1hh_כu+ Hu}ʂ㛬&Xf/Nf`TҖ}PMCZWjSAàsNL~m-0揙N/!u:,q{F>l ]?$SŚֱAۖ~s:!m'bddubwzWal&q=zdQױoj%Nqc#A,ԉvwaB̢h(-ʅ@g MtQ9*YEvؑe٨^5C A61[ &j/GsvD=GڑsۉX왃ʡ %ӝK5!!7=Fx ܥ1 8i.W~\nIE*ȱIʏAjhICnޥgH~4@ekʘ9Lz}a7ÊF-=Lm^R RDI;z[v@A2 ^uǾq"dDzB!G9y١۱(aPnU[oh&H‹̌5W҃Di'0*yr;э tcё ]m0TXHAI?kJ 54܉HCJ+,HBhH6Ȕ8FΗ1?1JcDϩD:U VN4_5k(;G2I Ðc|u3ʴewbYK;tu l':vUyҷӐh>6a5drMC<-Bɕ㫄hȚǕ=ĕ8@G)=`%6~w/|h|R4Rvf=fjI_W;D X5+\K\X ?2AP6q >1b(?ߡ8K%X6${ى,ՅthPұ%e-F!ʦKU.$$&b#VW/n&Oo~t[OgBdo4ht$|Y&+`;*mO9Xh#\W\MOH=Rg^U&m Zb\0 ^{Bowx:g\E46=x967rw'<ݤnu~;>Z[;S$lЁ5#"MX|qV~_c` ueՔظ|cFנlݓ|g&SLa#^$A+Iendstream endobj 83 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 240 >> stream xcd`ab`dddw 441%(gaa}E3'@r<E9 L Y49{f{?3T^%:gnU6UUv#TtÛO]fm Z7tɵ&yuvG _>tW7~SOw{sgL?~Kױloj+%ːW>b1ozfendstream endobj 84 0 obj << /Filter /FlateDecode /Length 2411 >> stream xXKs뾷=|P%˜ZF.[Hr`\0 ɈI&AT{ʰJ _wϧIIN|uO>qvW^r=*ʈQ'\71fB-y圝Mgt+˺R9g4ΤY>JXELVhnwqUlm3 n7S:W e$kWQR}x&nW[ה(HK>NMNNqj! a{vUm//>M4)$8 ۦj|uu( &ݲ$lܰrSZT$*撳E8nƢ'̤3M&46%x(J{xMՙ8hϓV-Ih 2HP:e$^>ĤDP=&Fi#fk7 z zz K D^-PpM H4.i_A 4D@]IJ3Y8 ӆjlU!d=3 (D# :+؏QtAc+oc3D\e@9$6xJt8}yYtР%SO>JB5uA2t 1-  ^|čأG: Pr JJ ؄]hqrМÒ[p=iN|$a$P=豙)3fBi&uAX?:Ls3I)(XyT~@k[,0nLK=kS$Eꗠs 8nj+ehO8L;.8QaCd2׭?ލ鸃B)b|*QݗJS)kU_koSc+5$eߥ&ǣHv-i_ ;rv8?4'U?LC_B/x^$< a?_7--Ӿ8^,}kPxlZ)I$LDcv-:~}>n+1͍Uavת;;CRF Y zdpI0ٿpM EqS_{0|GJ@s^Syz-j7e{n|TmR'U4jU־'̉QyY3yO-6Pwhpe${o9GLh?>rS0eO{a !LR#8<~pYt j1om^vm~4o *:]ȢWRUم2 ,[c* 3[UhiEK! F`P*U獗`s@yW?]6Aa"p_cO\ƂgϞ>Z¬S}s7"Bz }8]da&_d1݇r5lKej-`HK0(&ܓB+ڎ Mvu(?,øW4yp +<`?,bi$eBCGzYW}i}Us@L|ۏP/}~.EZ?^멣N~s\6o2b IsU&=l ~DtԤȚl0.0vUnXi e> stream x-oHq62̂;^(/0@L" i[vwn:n;OM0F EȊ^W *>/XqKZΜ}?[ LAD4)u]gIȨ0&*ߵh81t7 F@z!HϥX@b{Hxrn9y嵚IDBV¡f4:yZ7:ay`wG)!(wT ,PH=\ .j)OBw+bt0kdI #KpU'kc+/D3^E3IX@TMAn9w#UkDh D=6t#L'( 8Rf?endstream endobj 86 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6642 >> stream xywtuh, 1;si!B.KO 88q[Huɲ$wB*<v]bR2i5JX 5},œv|qPift}4<-P~[k=RpK4-jKh? 44BĕM<6v[nq2)1IW.$r\B!=D('t-ż*gxnJ4[Qt^O1jyox. oi+VC]W!/Q-Zhma[z _}/ a{ĭi{t8v@3^qO(r>¾e;D" Hc]gL-\7 \q]3qSvإi_K,wwe$t[GM\Kt5͹٪3O!0 ٟK Ďw-"$Jە*Caׅ)Ҝ/MTMLѶ1 f={%/Aoz_CzJI$ᇉ.?+aO=@۴uνskcW?HޑJ/ɱ#À0|f01f2xpȈH@<.邱P<Ã#M[ZZ~Jri*IQ\r~怴֏EjF.T>d[M{k rSNxk KP}bƟX(Te&J[hRBݘ, zxb9r })L #I381 up'ujZkqYexLGB@dHS' #.I/~+K)5ꛃa *gLrxf\iggRgGu יl9fZH%bD0'N@ u]fe+0g<K`]=hIY}ec8-^,0Mdz\iH.2F ';_tOM׵X@zKt6p#b(ɳhJ>vUmv ݢW2n?ZZ`l`G}˩hė꽖㦨97Xږ [JxuU*s/0|LXѫB; /:3{ߐ̺Թ.q넜/@LgT9tyP:8Y|#]&n!_nHzN~ųc<~@ z >vRLsJmvLjq0!b:)k𴝱y%}=Q;ܔ >$<H?%tAN 0U$fmSCPjTzPJ$RûԲ&f:ʼn~}j4'ewl77^ ɧNEwoԆy87rvnsVMІ[btuOnòNZxx-˶Ku vm=2R(κeh9}:a$bt Yx fؙG8, y5=XK٩7BeIOmCݶk.O{KiJ%[!p>T});wOk}c~2f͟#eȫX&':=HE!/KI m")ޥ6:c` W>;'09, x`;͛ɐڟ u:I ]08bPpG>B6b"aHt$<ޥrힺQ/qV(=9}VҧEVPb-<=xm|[_(ӉהsB)%">kq6hA,N.IڣfJrzrX,;?!X\Y5^M;V3^^?%vPHdž{<xZ,FRi,ğ;~I,0Ch= (эzYH+&+没VSO`_׃5XsҨ FIM68VLß ]4hHHGiBzk-B=zP*=?w.* Lk;AG%ڢ|ʩޫ~E Z](\̿M9Qi~)Y߶;u)xJ9Ic t6o W/c #ҒP.i8Du0{v#D!蹹H]YqB7&8Qga@W@G9vA| "=f~ktq* {1X; a,k&i5NW앖-K}]6@S'P(b${ N!9t$X &d ɹ/>QjȦxcOKVCyMCCG7U/@۽%! #l$b^Rx%~H>nd;ƈ|dp.]%?`pҿ#: ad@P׺Mҏ!' smon$]p::MYR&7b.'mG(#ɤ|?Ԕ̳ϰ wxc{epu"+oǟ-M˱scDPYA".A W7 ,ou k >/+˴>Hұ;JfR&~۫pWJX[d'Up>f֦}/{_IүI/ 4KɌ*߳R?XTZ \nD"K}7I%> v<)'8Y"&GT|A n dw1if Ou6zkㅍ3)ǻ1cru!Iw9C HxZGIf us\H6G#܅;lH1bl_Xu_<]=`]\?E,>nWA¿>5->_ưް]RBkG3hb _ª aAag3dz7E\0ٔ]ƴpsV [ .ύ>)el>;mKtu-77ٜF pl=2473gK%s<lY u40sNOLZ>eK @#|bM4!4ib@z+O[n|@6RSó}%~lTizi~l6B-N+ԏ}8~#l- PD!>'{}B\MѲ_TrP夣E /z濤gZi vPU1m"jihb粯O9$ !3@ gFr濎Ǐ5fWH~[A}.`0ُuu1fˠxAsP4A8(xH<.҈)> 9򐴂C=%|Nu!}1q\ DzG;X_XSCVUVMz{4KWKXegR•W\jJZ>&agGFˍZU';$ydrc1jD3%,T" wG2;D 靰o\jmtG;jƄ%ӝ!42dAVzulxt!$k>5!Vn^C^[ŒDu@B>޲'nn`}%OSb0zPZtRԼ'5j ڏ.LU.t|^۵X tQІO~dPK]g! TBPúZ"(6 -P SZm5:@I!_'1׷kanRp Na`~ %mr;=AȒL6cAÂlG*&#>9bNcG? !:Y6؎Q.&z@4+ c.҇1bTe0ȡL6ii iƺM;m&sl(?H^"6Ku޷8pq$H0:n6+c+o4nE\<1RLȑuͲY.ϜW(D7Ic <φw"eYѹNFҶFKN*=ᳺPOCT~Tsm^RK~n" }GJAḇʡՀܓai"zx 9ֲ>je C c_ )Ȇޣ*}\i- P2,nkmqn&W+$ _3<̉lvb 4NsARbgq:0`bBޠo3"\ղ\ߋX@wv:<)}Ћ4RŭkZ׽*0L<Di'eKpy35V"sy7$ωsxy]mtD\ E*C̞B@APIw`f0f困jėACN'Ao; dlkJǮu%>t("`߉ 9> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 88 /ID [] >> stream xcb&F~ c%ygeb`} 0" $w @$亁<`qc Language-Team: Vincent Goulet MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); la procdure LAPACK dgebal a produit le code d'erreur %d lors de la permutationla procdure LAPACK dgebal a produit le code d'erreur %d lors de la mis l'chellela procdure LAPACK dgetrf a produit le code d'erreur %dla procdure LAPACK dgetrs a produit le code d'erreur %dargument incorrectmatrice non carreexpm/inst/po/fr/LC_MESSAGES/expm.mo0000644000176200001440000000213114107534174016323 0ustar liggesusersT :8+-+YtOSm883FLAPACK routine dgebal returned info code %d when permutingLAPACK routine dgebal returned info code %d when scalingLAPACK routine dgetrf returned info code %dLAPACK routine dgetrs returned info code %dinvalid argumentnon-square matrixProject-Id-Version: expm 0.999-0 Report-Msgid-Bugs-To: PO-Revision-Date: 2007-11-20 13:56-0500 Last-Translator: Vincent Goulet Language-Team: Vincent Goulet Language: fr MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); la procdure LAPACK dgebal a produit le code d'erreur %d lors de la permutationla procdure LAPACK dgebal a produit le code d'erreur %d lors de la mis l'chellela procdure LAPACK dgetrf a produit le code d'erreur %dla procdure LAPACK dgetrs a produit le code d'erreur %dargument incorrectmatrice non carreexpm/inst/po/de/0000755000176200001440000000000014547731235013221 5ustar liggesusersexpm/inst/po/de/LC_MESSAGES/0000755000176200001440000000000014547731235015006 5ustar liggesusersexpm/inst/po/de/LC_MESSAGES/R-expm.mo0000644000176200001440000000311714107534174016510 0ustar liggesusers 013N'6;&D2]7 'A:+|@;1%WFqG   '%s' must be a square matrix'A' must be a square matrix of dimension at least 2A and E need to have the same dimensionPade approximation order 'p' must be between 1 and 13.The requested tolerance (tol=%g) is too small for mxrej=%d.Unable to determine matrix exponentialargument is not a matrixcoercing to dense matrix, as required by method %sinvalid 'method'invalid 'preconditioning'matrix not squarereached maxiter = %d iterations; tolerances too small?Project-Id-Version: expm 0.999-6 PO-Revision-Date: 2021-08-19 21:57+0200 Last-Translator: Martin Maechler Language-Team: German Language: de MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit '%s' muss eine quadratische Matrix sein'A' muss eine quadratische Matrix der Dimension mindestens 2 seinA und E müssen die gleiche Dimension habenPadé Approximation der Ordnung 'p' muss zwischen 1 und 13 sein.Die verlangte Toleranz (tol=%g) ist zu klein für mxrej=%d.Das Matrix Exponential kann nicht bestimmt werdenArgument ist keine MatrixUmwandlung in dichte ("dense") Matrix, wie von der Methode %s verlangtungültige 'method'ungültiges 'preconditioning'Matrix ist nicht quadratischhaben maxiter = %d Iterationen erreicht; sind die Toleranzen zu klein?expm/inst/po/expm-de/0000755000176200001440000000000014547731235014170 5ustar liggesusersexpm/inst/po/expm-de/LC_MESSAGES/0000755000176200001440000000000014547731235015755 5ustar liggesusersexpm/inst/po/expm-de/LC_MESSAGES/expm.mo0000644000176200001440000000103514107534174017255 0ustar liggesusers4L`7aBargument type='%s' must be one of 'N', 'P', 'S', or 'B'non-square matrixProject-Id-Version: expm 0.999-6 Report-Msgid-Bugs-To: PO-Revision-Date: 2021-08-19 21:14+0200 Last-Translator: FULL NAME Language-Team: German Language: de MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit Das Argument type='%s' muss eines von 'N', 'P', 'S', oder 'B' seinkeine quadratische Matrixexpm/inst/po/en@quot/0000755000176200001440000000000014547731235014244 5ustar liggesusersexpm/inst/po/en@quot/LC_MESSAGES/0000755000176200001440000000000014547731235016031 5ustar liggesusersexpm/inst/po/en@quot/LC_MESSAGES/R-expm.mo0000644000176200001440000000510514107534174017532 0ustar liggesusers &3:1n2'&Z"+}63;/&k2$ .@7U 756H'&Z+):U3;& B 2[   $   7     '%s' must be a square matrix'A' is not a matrix'A' must be a square matrix of dimension at least 2'lucky guess' was better and is used for expmCond'x' has negative real eigenvalues; maybe ok for %sA and E need to have the same dimensionInverse scaling did not work (t = %g).NA/NaN from || Tr - I || after %d step. %sNA/NaN from || Tr - I || after %d steps. %sNaN phi values; probably overflow in expm()Pade approximation order 'p' must be between 1 and 13.Setting m = 3 arbitrarily.The matrix logarithm may not exist for this matrix.The requested tolerance (tol=%g) is too small for mxrej=%d.Unable to determine matrix exponentialargument is not a matrixcoercing to dense matrix, as required by method %sinvalid 'method'invalid 'preconditioning'logm.Higham08() -> (k, m) = (%d, %d)matrix not squarenrow(A) must be >= 1reached maxiter = %d iterations; tolerances too small?Project-Id-Version: expm 0.999-6 PO-Revision-Date: 2021-08-19 21:54 Last-Translator: Automatically generated Language-Team: none MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Language: en Plural-Forms: nplurals=2; plural=(n != 1); ‘%s’ must be a square matrix‘A’ is not a matrix‘A’ must be a square matrix of dimension at least 2‘lucky guess’ was better and is used for expmCond‘x’ has negative real eigenvalues; maybe ok for %sA and E need to have the same dimensionInverse scaling did not work (t = %g).NA/NaN from || Tr - I || after %d step. %sNA/NaN from || Tr - I || after %d steps. %sNaN phi values; probably overflow in expm()Pade approximation order ‘p’ must be between 1 and 13.Setting m = 3 arbitrarily.The matrix logarithm may not exist for this matrix.The requested tolerance (tol=%g) is too small for mxrej=%d.Unable to determine matrix exponentialargument is not a matrixcoercing to dense matrix, as required by method %sinvalid ‘method’invalid ‘preconditioning’logm.Higham08() -> (k, m) = (%d, %d)matrix not squarenrow(A) must be >= 1reached maxiter = %d iterations; tolerances too small?expm/inst/po/en@quot/LC_MESSAGES/expm.mo0000644000176200001440000000457714107534174017347 0ustar liggesusers\:8 +E+q+),5 @V7'/.^&o J/:08k+++)(,R5DK'F n3& ' J4     LAPACK routine dgebal returned info code %d when permutingLAPACK routine dgebal returned info code %d when scalingLAPACK routine dgetrf returned info code %dLAPACK routine dgetrs returned info code %dLAPACK' dgebal("B",.) returned info code %dLAPACK's dgebal(%s) returned info code %dR_dgebal(*, type="S"): Infinite matrix entryargument %d of Lapack routine dgesv had invalid valueargument type='%s' must be a character string of string length 1argument type='%s' must be one of 'N', 'P', 'S', or 'B'error code %d from Lapack routine dgeevinvalid 'kind' argument: %s invalid 'precond_kind: %dinvalid 'x': not a numeric (classical R) matrixinvalid argumentinvalid argument: not a numeric matrixnon-square matrixnot a matrixpower must be a positive integer; use solve() directly for negative powersProject-Id-Version: expm 0.999-6 Report-Msgid-Bugs-To: PO-Revision-Date: 2021-08-19 21:49+0200 Last-Translator: Automatically generated Language-Team: none Language: en MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n != 1); LAPACK routine dgebal returned info code %d when permutingLAPACK routine dgebal returned info code %d when scalingLAPACK routine dgetrf returned info code %dLAPACK routine dgetrs returned info code %dLAPACK' dgebal("B",.) returned info code %dLAPACK's dgebal(%s) returned info code %dR_dgebal(*, type="S"): Infinite matrix entryargument %d of Lapack routine dgesv had invalid valueargument type=‘%s’ must be a character string of string length 1argument type=‘%s’ must be one of ‘N’, ‘P’, ‘S’, or ‘B’error code %d from Lapack routine dgeevinvalid ‘kind’ argument: %s invalid 'precond_kind: %dinvalid ‘x’: not a numeric (classical R) matrixinvalid argumentinvalid argument: not a numeric matrixnon-square matrixnot a matrixpower must be a positive integer; use solve() directly for negative powersexpm/po/0000755000176200001440000000000014547731235011654 5ustar liggesusersexpm/po/expm-de.po0000644000176200001440000000471714107534174013557 0ustar liggesusers# Translation of expm.pot to German # Copyright (C) 2021 Martin Maechler # This file is distributed under the same license as the expm package. # Martin Maechler , 2021. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: expm 0.999-6\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2021-08-19 20:28+0200\n" "PO-Revision-Date: 2021-08-19 21:14+0200\n" "Last-Translator: FULL NAME \n" "Language-Team: German \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=utf-8\n" "Content-Transfer-Encoding: 8bit\n" #: R_dgebal.c:11 #, c-format, fuzzy msgid "argument type='%s' must be a character string of string length 1" msgstr "Das Argument type=\"%s\" muss eine Buchstabenfolge der Länge 1 sein" #: R_dgebal.c:16 #, c-format msgid "argument type='%s' must be one of 'N', 'P', 'S', or 'B'" msgstr "Das Argument type='%s' muss eines von 'N', 'P', 'S', oder 'B' sein" #: R_dgebal.c:28 msgid "invalid 'x': not a numeric (classical R) matrix" msgstr "" #: R_dgebal.c:32 expm-eigen.c:209 expm.c:307 logm-eigen.c:213 matpow.c:23 msgid "non-square matrix" msgstr "keine quadratische Matrix" #: R_dgebal.c:46 msgid "R_dgebal(*, type=\"S\"): Infinite matrix entry" msgstr "" #: R_dgebal.c:69 #, c-format msgid "LAPACK's dgebal(%s) returned info code %d" msgstr "" #: expm-eigen.c:60 expm-eigen.c:68 logm-eigen.c:64 logm-eigen.c:72 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:118 logm-eigen.c:122 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:200 expm.c:289 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:101 #, c-format msgid "LAPACK routine dgebal returned info code %d when permuting" msgstr "" #: expm.c:106 #, c-format msgid "LAPACK routine dgebal returned info code %d when scaling" msgstr "" #: expm.c:112 #, c-format msgid "LAPACK' dgebal(\"B\",.) returned info code %d" msgstr "" #: expm.c:116 #, c-format msgid "invalid 'precond_kind: %d" msgstr "" #: expm.c:165 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "" #: expm.c:168 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "" #: expm.c:302 #, c-format msgid "invalid 'kind' argument: %s\n" msgstr "" #: logm-eigen.c:207 msgid "invalid argument" msgstr "" #: matpow.c:14 msgid "not a matrix" msgstr "" #: matpow.c:54 msgid "" "power must be a positive integer; use solve() directly for negative powers" msgstr "" expm/po/expm.pot0000644000176200001440000000445214107534174013351 0ustar liggesusers# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the expm package. # FIRST AUTHOR , YEAR. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: expm 0.999-6\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2021-08-19 21:49+0200\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" #: R_dgebal.c:11 #, c-format msgid "argument type='%s' must be a character string of string length 1" msgstr "" #: R_dgebal.c:16 #, c-format msgid "argument type='%s' must be one of 'N', 'P', 'S', or 'B'" msgstr "" #: R_dgebal.c:28 msgid "invalid 'x': not a numeric (classical R) matrix" msgstr "" #: R_dgebal.c:32 expm-eigen.c:209 expm.c:307 logm-eigen.c:213 matpow.c:23 msgid "non-square matrix" msgstr "" #: R_dgebal.c:46 msgid "R_dgebal(*, type=\"S\"): Infinite matrix entry" msgstr "" #: R_dgebal.c:69 #, c-format msgid "LAPACK's dgebal(%s) returned info code %d" msgstr "" #: expm-eigen.c:60 expm-eigen.c:68 logm-eigen.c:64 logm-eigen.c:72 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:118 logm-eigen.c:122 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:200 expm.c:289 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:101 #, c-format msgid "LAPACK routine dgebal returned info code %d when permuting" msgstr "" #: expm.c:106 #, c-format msgid "LAPACK routine dgebal returned info code %d when scaling" msgstr "" #: expm.c:112 #, c-format msgid "LAPACK' dgebal(\"B\",.) returned info code %d" msgstr "" #: expm.c:116 #, c-format msgid "invalid 'precond_kind: %d" msgstr "" #: expm.c:165 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "" #: expm.c:168 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "" #: expm.c:302 #, c-format msgid "invalid 'kind' argument: %s\n" msgstr "" #: logm-eigen.c:207 msgid "invalid argument" msgstr "" #: matpow.c:14 msgid "not a matrix" msgstr "" #: matpow.c:54 msgid "" "power must be a positive integer; use solve() directly for negative powers" msgstr "" expm/po/R-de.po0000644000176200001440000000461014107534174012777 0ustar liggesusers# Copyright (C) 2021 Martin Maechler # This file is distributed under the same license as the expm package. # Martin Maechler , 2021. msgid "" msgstr "" "Project-Id-Version: expm 0.999-6\n" "POT-Creation-Date: 2021-08-19 21:54\n" "PO-Revision-Date: 2021-08-19 21:57+0200\n" "Last-Translator: Martin Maechler \n" "Language-Team: German \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=utf-8\n" "Content-Transfer-Encoding: 8bit\n" msgid "argument is not a matrix" msgstr "Argument ist keine Matrix" msgid "matrix not square" msgstr "Matrix ist nicht quadratisch" msgid "coercing to dense matrix, as required by method %s" msgstr "Umwandlung in dichte (\"dense\") Matrix, wie von der Methode %s verlangt" msgid "invalid 'preconditioning'" msgstr "ungültiges 'preconditioning'" msgid "Unable to determine matrix exponential" msgstr "Das Matrix Exponential kann nicht bestimmt werden" msgid "'%s' must be a square matrix" msgstr "'%s' muss eine quadratische Matrix sein" msgid "Pade approximation order 'p' must be between 1 and 13." msgstr "Padé Approximation der Ordnung 'p' muss zwischen 1 und 13 sein." msgid "'A' must be a square matrix of dimension at least 2" msgstr "'A' muss eine quadratische Matrix der Dimension mindestens 2 sein" msgid "invalid 'method'" msgstr "ungültige 'method'" msgid "'lucky guess' was better and is used for expmCond" msgstr "" msgid "reached maxiter = %d iterations; tolerances too small?" msgstr "" "haben maxiter = %d Iterationen erreicht; sind die Toleranzen zu klein?" msgid "A and E need to have the same dimension" msgstr "A und E müssen die gleiche Dimension haben" msgid "'A' is not a matrix" msgstr "" msgid "nrow(A) must be >= 1" msgstr "" msgid "NaN phi values; probably overflow in expm()" msgstr "" msgid "The requested tolerance (tol=%g) is too small for mxrej=%d." msgstr "Die verlangte Toleranz (tol=%g) ist zu klein für mxrej=%d." msgid "'x' has negative real eigenvalues; maybe ok for %s" msgstr "" msgid "The matrix logarithm may not exist for this matrix." msgstr "" msgid "Inverse scaling did not work (t = %g)." msgstr "" msgid "Setting m = 3 arbitrarily." msgstr "" msgid "logm.Higham08() -> (k, m) = (%d, %d)" msgstr "" msgid "" "NA/NaN from || Tr - I || after %d step.\n" "%s" msgid_plural "" "NA/NaN from || Tr - I || after %d steps.\n" "%s" msgstr[0] "" msgstr[1] "" expm/po/R-expm.pot0000644000176200001440000000324014107534174013542 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: expm 0.999-6\n" "POT-Creation-Date: 2021-08-19 21:54\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" msgid "argument is not a matrix" msgstr "" msgid "matrix not square" msgstr "" msgid "coercing to dense matrix, as required by method %s" msgstr "" msgid "invalid 'preconditioning'" msgstr "" msgid "Unable to determine matrix exponential" msgstr "" msgid "'%s' must be a square matrix" msgstr "" msgid "Pade approximation order 'p' must be between 1 and 13." msgstr "" msgid "'A' must be a square matrix of dimension at least 2" msgstr "" msgid "invalid 'method'" msgstr "" msgid "'lucky guess' was better and is used for expmCond" msgstr "" msgid "reached maxiter = %d iterations; tolerances too small?" msgstr "" msgid "A and E need to have the same dimension" msgstr "" msgid "'A' is not a matrix" msgstr "" msgid "nrow(A) must be >= 1" msgstr "" msgid "NaN phi values; probably overflow in expm()" msgstr "" msgid "The requested tolerance (tol=%g) is too small for mxrej=%d." msgstr "" msgid "'x' has negative real eigenvalues; maybe ok for %s" msgstr "" msgid "The matrix logarithm may not exist for this matrix." msgstr "" msgid "Inverse scaling did not work (t = %g)." msgstr "" msgid "Setting m = 3 arbitrarily." msgstr "" msgid "logm.Higham08() -> (k, m) = (%d, %d)" msgstr "" msgid "NA/NaN from || Tr - I || after %d step.\n%s" msgid_plural "NA/NaN from || Tr - I || after %d steps.\n%s" msgstr[0] "" msgstr[1] "" expm/po/fr.po0000644000176200001440000000565614107534174012632 0ustar liggesusers# French translations for expm package # Traduction franaise du package expm. # Copyright (C) 2007 Vincent Goulet # This file is distributed under the same license as the expm package. # Vincent Goulet , 2007. # msgid "" msgstr "" "Project-Id-Version: expm 0.999-0\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2021-08-19 20:28+0200\n" "PO-Revision-Date: 2007-11-20 13:56-0500\n" "Last-Translator: Vincent Goulet \n" "Language-Team: Vincent Goulet \n" "Language: fr\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" #: R_dgebal.c:11 #, c-format msgid "argument type='%s' must be a character string of string length 1" msgstr "" #: R_dgebal.c:16 #, c-format msgid "argument type='%s' must be one of 'N', 'P', 'S', or 'B'" msgstr "" #: R_dgebal.c:28 msgid "invalid 'x': not a numeric (classical R) matrix" msgstr "" #: R_dgebal.c:32 expm-eigen.c:209 expm.c:307 logm-eigen.c:213 matpow.c:23 msgid "non-square matrix" msgstr "matrice non carre" #: R_dgebal.c:46 msgid "R_dgebal(*, type=\"S\"): Infinite matrix entry" msgstr "" #: R_dgebal.c:69 #, fuzzy, c-format msgid "LAPACK's dgebal(%s) returned info code %d" msgstr "la procdure LAPACK dgetrs a produit le code d'erreur %d" #: expm-eigen.c:60 expm-eigen.c:68 logm-eigen.c:64 logm-eigen.c:72 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:118 logm-eigen.c:122 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:200 expm.c:289 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:101 #, c-format msgid "LAPACK routine dgebal returned info code %d when permuting" msgstr "" "la procdure LAPACK dgebal a produit le code d'erreur %d lors de la " "permutation" #: expm.c:106 #, c-format msgid "LAPACK routine dgebal returned info code %d when scaling" msgstr "" "la procdure LAPACK dgebal a produit le code d'erreur %d lors de la mis " "l'chelle" #: expm.c:112 #, fuzzy, c-format msgid "LAPACK' dgebal(\"B\",.) returned info code %d" msgstr "la procdure LAPACK dgetrf a produit le code d'erreur %d" #: expm.c:116 #, c-format msgid "invalid 'precond_kind: %d" msgstr "" #: expm.c:165 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "la procdure LAPACK dgetrf a produit le code d'erreur %d" #: expm.c:168 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "la procdure LAPACK dgetrs a produit le code d'erreur %d" #: expm.c:302 #, fuzzy, c-format msgid "invalid 'kind' argument: %s\n" msgstr "argument incorrect" #: logm-eigen.c:207 msgid "invalid argument" msgstr "argument incorrect" #: matpow.c:14 #, fuzzy msgid "not a matrix" msgstr "matrice non carre" #: matpow.c:54 msgid "" "power must be a positive integer; use solve() directly for negative powers" msgstr ""