expm/0000755000176200001440000000000013777557164011251 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/0000755000176200001440000000000013777326437012172 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/ChangeLog0000644000176200001440000002034313777326364013021 0ustar liggesusers2021-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/0000755000176200001440000000000013777326437012157 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/0000755000176200001440000000000013777326437012021 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.Rd0000644000176200001440000000630312407501461014044 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{http://eprints.ma.man.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.Rd0000644000176200001440000000576413777072735013710 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 : ---- 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.Rd0000644000176200001440000001122413777326364014624 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 \enumerate{ \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, N.~J. (2008). \emph{Functions of Matrices: Theory and Computation}; Society for Industrial and Applied Mathematics, Philadelphia, PA, USA. 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). } \seealso{ For now, the other algorithms \code{\link{expm}}. \bold{This will change there will be one function with optional arguments to chose the 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/DESCRIPTION0000644000176200001440000000136213777557164012761 0ustar liggesusersPackage: expm Type: Package Title: Matrix Exponential, Log, 'etc' Version: 0.999-6 Date: 2021-01-12 Author: Vincent Goulet, Christophe Dutang, Martin Maechler, David Firth, Marina Shapira, Michael Stadelmann Contact: expm-developers@lists.R-forge.R-project.org Maintainer: Martin Maechler 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: http://R-Forge.R-project.org/projects/expm/ Encoding: UTF-8 NeedsCompilation: yes Packaged: 2021-01-12 14:07:43 UTC; maechler Repository: CRAN Date/Publication: 2021-01-13 11:50:12 UTC expm/build/0000755000176200001440000000000013777326457012347 5ustar liggesusersexpm/build/vignette.rds0000644000176200001440000000031313777326457014703 0ustar liggesusersb```b`a`f`b2 1#PHsV啣g+d2 S.HICg ^, &$UyF楀aީE0=(jؠjX2sRad9.nP&c0Gq?gQ~nݣ9JI,IK+>-expm/build/partial.rdb0000644000176200001440000003101713777326447014475 0ustar liggesusers}y|vV[,˶3^Z"ݭ۶l˲oLqx {?Um&k_{@YjT7:ƈJx/p?PS랲ZU+@./G] ~ԇx*:/D! @Q%0x@hxsOz ʃ7R҇x"2U_W͆톑|*Bu˥|CO9 Kg?}G2Wn2|ER˨z`Fٲ5+6l5ʬOTScuǴDSS7!ߔNcdLmrtަRKy֘^o6L[55ʋ3}+̪PXv4ه$>02s9"2 *Փdvg P]˺z#g!M"|{zr[Mwk6<9To402|D PQTW^;nza"KdzcR3k7-,JT{2ޅ|?eRB. T.EVkѥxR7<t ǙfWn 8< Y~ 2jKjf3ݢbQyf Ed7R0Q:<ﹺu\++eis3ҩTQԜ5=#sRk SW( S0S>mJ˔Uw@x8PUiJ/JYTB "c6e%w%K4M|| \ˌFzW A ZRM7^=܇ ٨/ADx4*lp lh.zfZ[tUZV2= vgYbQxs7LTi1MUM35,XMf s^G3 ŝhZ΁?}ri*k&>ZzYӗt f::zaB)9Xr P~8y1:ف[(aH4%:}!`t7n Dnv2P}xy88-% %3;;C$C&dVCZԡi i*gȡUZuH2jPa'gG3ff߹b͘[|8P-Z L  RY ;<Y~O<q8~#ALȻ΋i3ݰ5sIʌ䔔fܦwcϛ#PjT({',I>d{nb.ִ*OhIUW9CMK+g,ḽ4є=9zi*V ]/[cx;[\=6p9[{īO}ߤn]>LUHf 3N}rDtdž0ކ|?vx65!Z 1Ҕ 舛+-8(7M3A<vCt7LQQD,_nlm<l-F7[{`c}pǁ[$lp@ vpL<$jCR*[ n0r66<CxhDrY3tpP%]%Wa&=G:-='puIw1ڢflU42ZS3kɹ!|trPrvfg)LM8gFZ" /ٱ؅x$}g R7<%]f''bˆMi2MͰE8s礹9x9N{z%Nk-yEp+cmǪ]SESF7{R>kMSD(wN]^wZA^R Iȓ_)HU[C_n(k\XDJooAЈ!颡)m޶9JCxZ xC<]qHQ)ȧK'MoΑ{ԿPJB5T~᪅RidQ!: L$䓑h1D&F'!77W!Qᾨ!k[=dQB ,NL+iQ!:Gc}e!uCFY OFz솺MSWmg|}*K_&!8cC"%6B5kj߁N[{Rȇx>F%"<B NZq mx0&{J'keg oae2覟z% b]ކ,`JUI{ ;+~FwD[@-^z%#3<+`u< YW[mݕ d&qR[}j;(: -ddL7^({B߮摍03Xu蓷ۇ#7Ӑ7 zҥKTTM g^*&!i;p%?Zٍpi~2erwP˔oF= L}e\nQ`}= ,F{8, dHUx|a{"s>#ImT7ϋ- ֚ ԬVN2ІMdQ]߬(͌YMow3H+@!fVee.js Bx,w)8]cJj%X5ކ|{k^$|%-'3އxǿmU[=G}>AH9}mS6#YrY=r,D3C-񖫟jؽ*)LBe8jR7am_xK5|g9K .-x֝x iqO<;6R>#I8[_&xa/tX 5+݄i|7& sCb,xc/G64e9y?9JM;$ PXo!?"u@oT%<ʜ̥c&j兺,\ψO^|GT U^(Lewb9@ %dI-;g&B!eȗ#+ǽ09J/PI`r(oҾ ~Dk2Q(o@`*U&㖫}M |tMķ{@`x_|"-W5[kn Ţ> `Hf@a:cn!\9NafcN調jz1C<]I9EȡJV` xr=eCK|(W}ysg=f}έ٪lhCh7VH3Et#- <*o\2)-9C{ek&])Y5`IT{MCvMH]K@YR7< wĐA9" 88(֯(MӐ)q`ro8sלwB]ǝra݄.l h{5CC A.R7<9T?- 'fq{RII 0:O[GG$W KM\W Ԁea*BrUam,F5wgUJxpkG!F4]> = d'm8y$z=!e pc뛖\OdfobU+8 <9ߴhD]+acNyb~l2L\J 9>GVW0.pAo9~6c6v# 4siKKzEw@DKsKs{ܰIfqm٤s#Hw8Y'Q*ϻ\ݢLtF!G芒a Iq=DٜʇIG@ >#IcVM^ZFU!<HdK.쐻VddE 0[? /P^ {,A;!슩[v)>Et$i1ver-tlDlS5j_-{2ښ;X5yAď vGTm9[{.v.xif5%>uDކ,^ r~&* Hm^85J!^]͙BuG3jkeI 2 ,+<YfGm҄/xM.S_mG7a Q -S H0$;7!WGJ^,^ WR?C<475_~gء{Ϛ`K,& 'sp'Lp3Îy*d(PkrŜ ,i8)Ӑ# + Xn|#ug6 k G5R!H}n1è*[XQwWK g3T{^eu^?/  P{rs =Fac(qOuoP+fO(d>{pޑ!wVf̽(ؓV]3|mRnZ(óqK^aALl$n`KjF—K;ģ g%lPkF!jŀ8nx?”Y≨tl>Cm (FdY>J$JJ@[MCvs yRqR8@P1mbaKK4ɺ@_ ℷ!ߖNogf{Njb4"iד'5x&!7Ң~xyn X,Є2gJ%'"Sއ|,}$IgK۵Ē5M5-F[.g2$vq#݄GHp^[յ!Ar-e@H!˯I ʕgs!|n]9; <tiY&Ȗ5^$CT^nD+\=ORy>N4[6[zkѨYׯ_~H}XmcG7xX(wy%ͥY HȻ sgf$qD{ohub6:sS<;I춵WvRb$0Ip^įg?Vli]&Tۓ;Ͳ~Ys8i ;ŨW?T6xH{Q+"#[kѲ=KkNeYO )#[ju?=E VX:=WmᲾլ^ۿŪ{KzMxJ04gVwWc6~Y۹0!T$%h3rD4xGW'g4)w)a rJ,g͞83s,?q^Tv-;wh@՗<,Y鄈wtd9JR#˜YKv4³Dqx r++R7 |IÔpz]e|)ȡ*' Md&TH%bI64;!.l'ok#W WTo%Vɷ;rxBqgNΗez4mʖ*[ Tk[ebR{P6!_ъŚVwQ;PmsP( W!ڹ57:9T}L7{(g/J'pWgHf˕Wf=QHdKqg,͟ /C^X{i5+q:BtiֶZ5BgM*Pi>,UTKc{0-Ia_ j__j_)6J*=^A!<YQdג /u8)qsZH9'=q_>_iq|cdvg dESλY% ZF?<]t())i3u?+w*N8y&t|Rϔl!Yt6RSd!S2JR_(JTjJ:+oo4NK=2$&8;^ q̧^菁#$wa48ϷFIj >"C35) $CKS5OB?!i.{5w^ڟ1K9IiK ΪZӹj$ά5-f ӍFm5pi`4hބ,TU΋XqH5jUYOOIB-=?  cb2Jә\!JƙLLiSi"OG:͛kdsT^̥<aT*\.dYv#OG:w8gY3?|I[>+J)WLt| K(J4˪1XںZ-l9ZM7j8Zρ3a rI0?턃?2,8iaoofmmtqҲ8|EMX,Jٴ.R%.\!*f TAѐr:?)Me2s$>@[$t.YHy?.x7(`2_L2ieSJ oo4yzdqŒeΦRt?) 愷!ߖNQ_dr므 QGmuǺ*XF7ugQhTAw:wH2˖%Se%;Y><)JZTfY"rBȣ#AԿ3dP 9f,\:],x:PZIb6]ʤ9Z(<vs6Ճ3SxAYEIgk܍ݠݑ&\++厀ڄd/1̓m '⯁8at|/~ᯃat}B/M:k{C)兓BJ>ᅔBFgKx2Կ^(vrNBJT 'A#MFBk9R5uzM5YUsi5 &CH'oB;p'o!mO'8# PiF?j?)Mm!tZJyQ)FiqeJ8'C C;+ht ? R!Hw.XFݛ"^VX=at fk%d.U;W,L>gd&_ ?BN2\(L?9H)q­\2I BD+)lA)B-B:SLSx`ĉRL:QUT)QRpJV)(%JI.d(r/쏁EtG}Ts Z< 2QFgd0Y6SS6*۝O.K'tDt>%EɥҼ\O:UJEUJ? ?y:\OURm'*eR@TQ<~ *tv⼻jڪ枪ENrJ=at.4LA;p!mO/+iPiF?j?)j'矀i>ij,lU얩nhְh % iiiVX &?Q$dSMx 4~zI& [ρt/¤Dx n-LAM[//EJzjK;ҍSY${zMʄBR!|RնM}CushOCWfTYp} DZFwY^ϊB6_LRgKY-_A,pw?temj}Q[q&ɸ{j9o '߀4at/C1lVj>;!Ja.߂%ȡpL;h'3I˒4x +D8չ>Z輓^+{{p&,A.IqfakU͜.v gӻhժ 礹h ev]]kQKe[ja^ emTI/|8b[~d]#THQ≨TvVnEoG!:EH~@x ?C<л'Do͘{8oQiTyz0/Rćx@[]:?ɎB8nz 1onm7v7tt⯁=vu=wb^;dwu|o_xsBRS-{{*|Xms@g.Z|Ჭ5rѽR{]/';~HYS_td,x{vfP?+WW5N_Z{&E\]2IliZ$Ľ5Ѵt=]//KEUo'otg~ðix"-7ylIͬnƘmOyU}[Q՗|ou+a[ާei`[YsU]ݩ##՚~6S)eCeߣZu:F/V-lPM;2eziWꬡ[=Zas`PutKhԶT }&nr!s2+;mC_xj>E[t3חc]ܛ3_8YY+6g`hʦ=LCzt9&w G{ZgX6:]ShL߱:nN{6\~^=vzg{G/PU5tm9G{f*귓[Tl4^;̂ vO{ }ofםS}+ |t}wak'زeC*+w){r[Ћr\@Y+.{bSu*d^Q/}qw_ew/-K6zq^nkHaa0)ş?s_k9*gΏFΏt*(NVYiԽ)3TʊV ˞VTSN)k^;gu~]oN=x25dKJ:/,YmM;;^{>eOWvYO'ƕ6⛭u_uˣ m#/oO%8.׮>+Hc"TC2#wX+GQ=YZ #kcӐ& y8(Rw5v/}F;itH2| q$Ish4{W~ /I+U䔌 CQ-V n|b |Rw˟FUw(rx<(hnav>&/B<>1< l=?᠗3։" ng;1 ?ĥQ[NO! ?.^y?Vu -2/:\-U!W#~?~]ijt:eӗ1O( Y,׿7/pexpm/tests/0000755000176200001440000000000013777326437012410 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.R0000644000176200001440000003053013777072735014251 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 ## ^^^^^^^^^^^^ ## 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: expm.Matr.dge <- function(x) getDataPart(getMethod("expm", "dgeMatrix"))(Matrix::..2dge(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.R0000644000176200001440000001267413044611522013216 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, diag = 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), ] ), tolerance=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.R0000644000176200001440000001752713777072345013157 0ustar liggesuserslibrary(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. ## ---------------------------- ## 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")) 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=5e-15), all.equal(m4, m4T, check.attributes=FALSE, tolerance=5e-15), all.equal(m4, m4TO,check.attributes=FALSE, tolerance=5e-15), 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/0000755000176200001440000000000013777326457012037 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.c0000644000176200001440000000455413704012703013662 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[0], 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/0000755000176200001440000000000013777326457013260 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/0000755000176200001440000000000013777326437011447 5ustar liggesusersexpm/R/logm.R0000644000176200001440000000130512407501461012504 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("'x' must be a quadratic matrix") 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.R0000644000176200001440000003311212470351210014065 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") 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(sprintf("reached maxiter = %d iterations; tolerances too small?", maxiter)) ##-------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("'A' must be a square matrix") 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.R0000644000176200001440000001223113066656622012730 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("'x' must be a quadratic matrix") ##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(sprintf("'x' has negative real eigenvalues; maybe ok for %s", "sqrtm()")) 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(sprintf("R.index[n-k = %d]] is NULL, set to n=%d", n-k,n)) 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.R0000644000176200001440000000104313777072735013154 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)) } expm/R/logm.Higham08.R0000644000176200001440000002364713066656622014101 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(sprintf("'x' has negative real eigenvalues; maybe ok for %s", "logm()")) 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 %s after %d step.\n", "NA/NaN from %s after %d steps.\n"), " || Tr - I || ", 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(sprintf("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(sprintf("logm.Higham08() -> (k, m) = (%d, %d)", k,m)) ##------ 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(sprintf("R.index[n-k = %d]] is NULL, set to n=%d", n-k,n)) 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.R0000644000176200001440000001054013777072735012624 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("'A' must be a square matrix") 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("'x' must be a square matrix") 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.R0000644000176200001440000001625513777072735012553 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("coercing to dense matrix, as required by method ", dQuote(method)) 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/MD50000644000176200001440000000646213777557164011571 0ustar liggesusers1b14c704fc12bf1cd3a689cd5f5f9789 *ChangeLog 6369393fa6925d88e5d91251ed3179a3 *DESCRIPTION 126f13f1117be0fcb55ba5ca4e6ffc97 *NAMESPACE 1ccbe92c36ff0ce3d189dc3d87f1317c *R/balance.R 8a5c089e388fc7887fe84c789e20433c *R/expm.R 63bca6314b652b2a267d8dd079600c91 *R/expm2.R 77c50b87a3afd971fb795811e125019b *R/expmCond-all.R dbc522a7c2b2a50ce050493daba661e0 *R/expm_vec.R 6fde0acfeb30cef0efca9224283b2e20 *R/logm.Higham08.R e101cde2867ae010ca104d0cf5d9fbc3 *R/logm.R 45e07bacddb49c9238b3e9d1767992f7 *R/matpow.R 2edda55f39f40755078b08f674a0da43 *R/sqrtm.R 62dbcce738cc4dafde0cbb7a5b92aabc *TODO 82146e32c48f19acf97c83bfad923a07 *build/partial.rdb f39f92fb3b69627c84567bf4a9c8bb07 *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 c7a2a1f7a4922930f514982a3b3a2319 *inst/doc/expm.pdf 7a1b16cbc14582bd11282774a27c87f5 *inst/po/en@quot/LC_MESSAGES/R-expm.mo 501af6d6e25e337a5e502dac988a6bb6 *inst/po/en@quot/LC_MESSAGES/expm.mo 090f57b6ef84c46ab9fdd0b82699a60a *inst/po/fr/LC_MESSAGES/expm.mo 274e76f34f3671b5db44d6a1dbc701a9 *inst/po/fr/LC_MESSAGES/fr.mo 9a400ff096d03cebf5409130ec553ab6 *inst/test-tools.R f03fd2a41c35e8ff0a0d6d91468aa21b *man/balance.Rd 2681415ac9d47fdf5223de806c84042d *man/expAtv.Rd 5a388df487f5887dec144c081fefc084 *man/expm.Higham08.Rd f6cdcde1348cee9b7856a306591c013c *man/expm.Rd 40f63f9ffea19d1ce6c3dae3f9277caa *man/expmCond.Rd 697d7311ef6c64384bedb7a9c345b41c *man/expmFrechet.Rd 4bebe0d3ed49104170f40b5afd854d34 *man/logm.Rd 0835f0173e75dabe7a9b97ee7a540fd5 *man/matStig.Rd 25ffdff79449fea67c0f0ae69506fd33 *man/matpow.Rd 915ff3260a6359ff21eef5bc62c204da *man/sqrtm.Rd c988f5ca518069c3895e0dca17b5f91d *po/R-expm.pot c2180f601b2d26af619ae1c0b4fc9e33 *po/expm.pot beec477f1bec3d42eb1ca8d265354e30 *po/fr.po 3d90f59b3248da1e70798e94456b5c99 *src/Makevars d962e154a1fa708ec850fb4c0726843c *src/R_NLS_locale.h 432d7d15f5b37b6f2ca3cc198645b6fd *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 e743d83dd27b4939bda3c57eec9a5c7a *tests/ex.R bc2c371adf98d0a651f016dd92d468cf *tests/ex2.R 9db3bcf64665ac014f0263f167ce7084 *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/0000755000176200001440000000000013777326437012223 5ustar liggesusersexpm/inst/test-tools.R0000644000176200001440000001054412311702321014434 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() ## ---------------------------------------------------------------------- ## 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/0000755000176200001440000000000013777326457012772 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.pdf0000644000176200001440000016614713777326457014455 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3306 /Filter /FlateDecode /N 57 /First 456 >> stream x[S~ }k;V[XsN?d _ϑIJ`;Ʊd=}<$8Ɉ ID.391DgXb%'9adC70HZ M8<3 Tcpˠ")K$< LA%RcHk3Z (!tFЉ&C\ <5B}C S#3xl2Ddapbr&)$#5ɳrᙓ\CeEn!>3 3/Y\$I(ҐC(2f!P(ϸ@p#Ho_&`0 ͉Bs WBzW=peο<얼y㚼E9~<,c3?f,lN?/ {<~|v8.ٻUj@Ow0l޼i L`{T5=?9q88;fIwu9%nMrbPΫۻќ$w O ^z4:|pX^!L&W4׽ (R/ ss#tPd(N=#:%DV i'dt[trx# `dt_tPzoMo'ԥeUY@Mn ӫ{$L a) }ŠHۜYGmߨ]|J6KxE /`_ͯU ~a0z°垗e )Qm&v猵ą&n >=b&,%pPw4ָ,*`*5Ye_KY; /|zf.-EF1fYW/Q{)YRRڢoݥ㢠{t#zLO)B~(9ߏ5WutxN`F_~o҄Ija*Ճ蔠FtKuQj_ ?xzWZД:+3\J?I˗X 慁Fd>󑳖=P*b9_0!UU- 6 ] Wx{%7D2L2 oɖQ-! M\a|EKhn cIsnP~ۻ<_!Sv$7Ti#`.Y5w{}*U/]%s]_ksJ:2V{NU'4Y tS5A=q>NfT,! :tWGԹ-_dkVYjqz]̫l^CbhԖUTQ8^y{&KjӢU\яoim/n)esl~ƍk1m(ā0ـ| lX'?8:8ޏ(/lJt׸,m 6+% %ЛP:qH4ٻPsVcBLUt1v#Wj-scżO6iZ{Nq6 OtxIضuu_ .#SFf 6*gm',1 zwv DOը'u78 ^f˛E;cNiO~R&z_f/S';u#S$mӳ7Oq2]::-SGA1u% eGtyl [?ۺ6r<k mHkh[-ڂ;:QC[:_>Zij46[3K`k?,s.MCI ;M8;:oet Dr"?F~V@ Ox}7 &+ #uuendstream endobj 59 0 obj << /Subtype /XML /Type /Metadata /Length 1167 >> stream 2021-01-12T15:07:43+01:00 2021-01-12T15:07:43+01:00 TeX Untitled endstream endobj 60 0 obj << /Filter /FlateDecode /Length 2084 >> stream xXێ}/$ܧm%#66kX 603(eLIO̧/rI0iNJ**.68<ɟ޹\)b~7I7J’)Up|3?WӪ~@TҦ^k/'a3\B:s-F3E >zI,ҊOS#˪FD&XDQrfli+fҗ޻TpϺ 6v?sH HGV 9Qo`1,bF >|ɆoO++#^_eżn: gr!AjpLRyӱ@ f^Og!ي:lե&MIoa nW!뢗>m ~a@Ak#i9#FI)1m5-L.^GȍJr>R9ྩL+M*U(#񍨗f $v^lw&?yͮZCo۸5Su3.Dv%d<)DLWBN"T*S3^h#zbGӃqi8v H*=Aۉ7oy? YG2ējT3\qI#, $]Ǎ `DyY.X@YLn.4CLqJ5"Tx6K*l;߭>%1喆&*|8Z0b5b7K%&ɖVj5mRBr$%vwk'~) 7-ڦ^_tPn"22h'C;)/uQW `mX~}ADn'i B:wR>W\Sz2yPjkMlltF);]oE͇A8KBe ]q<+:K^w|pǐLN"JpAI|wJ+3ףA?ݻ럗L\YN{>%_ KE|ŀ3+擟&܏(Sxh*6@~@S7'IؼL8{Doւx${kGܹ}/֕eTX4 ;G鈞He^R*Yi?&F:|etPcZ2FKK:]4XA%X\NO|Cg܅pgG<$su8٤Ʉ'LhUL9B\B 7Pzwe鬑v~$*q=JQDn!V&L؋R>N&s38X|5Un{|- n"0 3Sܵ&/;?1ȼ뷤R>}g;#Ati ]в}i-pA}Y0y8ةѰCFz]`R,u;c| ,mm>tWcljl"vDmvm2hRVA{<ڈ%_1=Hž\ONƾp ZX1LD_}jW1XG_ RS̵ukY~F).%P#!pl=C,Xs]ԓ Ghfst46]#pMoڔ*f"^Z/ә&6C[/ޜ:EN RzoވōW> :`ݝTO7 >VwlϙR?{Gi >ίX[Hsœ?Bn;pykmg䙰L%aJdE}|zO};|Re<ʋj59G)^7͡iBջSW+lm l]'&sendstream endobj 61 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1518 >> stream x]}LSWo)\QU^u[en%:c"Ƞȇʇ).+R-|RЊ*D\Fn&:5d:O5q%99'Y9(\\di FiQ|.Ơwf3}w}QaR+_T+.J-*%!a]{r%`i:lmD3lzB/^mWa}L &{[52lp{@{`HVn:dȭH$Wϟ^p'Hj ԽF [H `yP-ɱ%Bls~HKg)jO4Lu&Lk=++>A!Q]Iuڪ`Te>8Ȱ>xi[FH@6?1ŬC@DKJEQ"l^SO=PM?m`l;uI @sAmMAUՄ`3 *?zO&SH>d3(TЏqU%:YA)ZZ\<ND_FE`?x6eendstream endobj 62 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 680 >> stream xm]HSawsͦyZ6*F sEpj~-4WLݎw:CliӜQhxQW7"AFFW<7xB$czRNHZZ^UiPMejbTkm2O )JңCǑlȍe$r#$ˈh8aH[h~eX<0k/?˯hM j-q̑[ݏ CrRA&"ڠp+LVO{U;TA$[;(2A#YGZZiRGhw'b PL1,Me!#Ȕۼ_a#H $3EfvDt{`[dxGB!uK RPAf_k%Kv%8}iՔmp]3fpuU-+sE@O].fBnR*߂"?5IKːh~ql},zzEE?⟹~N 5÷9ݠaXr^Y2ZD8;ݐo:kᾣ$ubA&wPch`2Lڙo5Lendstream endobj 63 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4553 >> stream xXyXW0sܰ%UkkiujEZ".,aOX'd!@ BKܰ U[U2;mqNÝp̝< y7~o ×Xo\"qcwcf>oڭ@4f7>Njgac?__ _oOM'_2 p$u]Z7ߔo[:|dGDr%X"lcff3 N&dev11:y&Y¬g2FM-E%&yb03f^%~)s4yw ? p <3uTUޝx}Ɠ3i}{֢Y1~|lcix$ !X g [=c87JwU(_aLU>卦Z_ ƒ"k5ӚeTJJvsib x@2VUiGx GnZ]!J_-ɖ7{w!N vak %uӢÒ6p0GBdY t~GU۶I8,ѥ&OK7XPw4%owuFrĔQ~L˻ɂ<7pl).% aq!*bx&#j8m0yXG`3ƔhmJH>Vϕcdv< AT0!E(.]t6?5%(SzDȖȓhZ1a~z|9G@RYgAdH[:HYO6]pc=GncQQŇ˂\vyq[D8_,/)p.=ZEl98-ۋG؍Cഇp0Ir}{jBdg F'd neI @ɆC i2a"$,Uɟ )JlU%@@At\qV_^[H<Ƨ{E9,x7HHV'N&y$zAOC[Kֻ ^Tj{x$2?Rכt, _ lΌb9|=׌sBnM`zi<ڏܙ*@ U>Oq*T>cPy 1U{4ʅ&KT`(_*4Sppjn˯s :7ʨs58ko-oDfH4]ο~Gl SB O*8aA/ h (9-:ŧa$ρ (a{&^ɕ oHF˰atA_J] SnHKd-,u$!:sZI/wsݨz@Qs[e%*&ab*cS ?5_ƟK]<(4>^\ȥ.ey]ω>$+.lجGpx'8!Ne[JDՔcBmaNh7Đ'!A|MJ&~i ~u ~E$jz]hd}ZAۑ->^USIzP14;+zӰGqTJnFF+B<:tBV2`+"7e7gu 8J $ W Qc,G2Oq]Vk59EyIœ9ǞtRoؑ?DHrDd^ abo-r/Ε$M4?5"|g>QF-!ϳkZ]+}dFX#5|H}{w:/˫燾yn4K)͜V*p4H 9iQwǡT$ѧR^?ssg-z.PPjf邊TGEȚ=}9t o_ 9~eHwѐ7r?]S=ʫ*l2X .|`B^z~b/$QBW'3CC&Ȇ+endstream endobj 64 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1737 >> stream x]{PTe]rs z&h0db58>(L" ]ay.ZP` eyT2Xc:L;36.1ci;3{~|??h'j]TaO\"b).B7/ |ܰ5$߶m Q0% )?劭*:'xֲ=g)ũǔwIQTRWӢ>p*KSH*NP;ET(RT kBT-MK$Oke_oPbߢ;ub;3ObdIQpD -(9ӜȳcwRES ލ&?z~>3hIQkdwTzkz9 66?O5J}罈ܪ8 GCcCO[rU-`F!d[ YO֑6";֓w(S*05S'2?s֤kʲ8V!1_$yr.nB[ء{p?̥נmIF'zCB4p$+pps}"vU1"x!x|2Tlw \;՚l 2QC[7՛Ms.\Lyqr;M@|ã2gv>Do~>$K `Yl`c*K%y ]1u,10wKA`,\0[-:Yus.{;fbsF NaC5Tn,ޙ u$?/tt 8y2' ,3J]1TeiI?8o碇k1` T(@%[6ٺ9\.Wťz2:\WJ4slldlt| _z]9kw\?]?ߓs:CBFN م#/ pjěx%  afldeOFo2@ӕ%؟_ !D )-ӕ@SjWVYscod*|HځH$fee`3L%FcEF8l y_endstream endobj 65 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2976 >> stream xmyXSgo^bb2kjZD*bDaKN"C"UZuikX[N:>Sg 1EgkW}w{$#H\|Bx{/vXddZ $7b,5n0E S;~B掛8II"MNLHN&9*:5iOrBl褨y0SIɾ)~i+"Q1qwLH\K Ye60@& f61 ƏgKJf5Y˸3<390,ܕt|oRtV8,*\> nuInN1y$vi;2z}ս.` <[}urE3_h+Ou@MƟ#{be@<z=ٝ)A5 dp-.D*)+ʰ9)ar2%kOEƝU@ }*t1;I>{3Z[2R̐ςl.0U DCTcU Gsno2lst|<츟- Thn^*%KήDx D#5idEź|QêcbEM[ okυ{Ov-@W0|m>L:լJNQBQp5 6|jޅ^cX?吡ﶴjʼn&{TͲIpj0C, ޱM&.ݙ%^s .P>f2(֕N+R2g|rءq_blbK_|vKeދg{pb\L2 O}[ 3A(G8_fvN}xTsfMvaymBOʍZ _Z R(*kkcU5eA)f0݇OzWpm_]#2H4$UZ">P WE[4 * 8zEf𠀝8ߵ9>dj=Kץ}mZCGJXzjžK襲pΙ_LU?A8vEv'Dɖ޾HQD}lnqjfFQ()ZE$/Ǚ,֮"?BvU}de_TF9PafR$]jdrIB`|LLjZXz'&d[[G{.w^ UPÙ4bX ₌-[Ӷ;Z-V2˳$tHFfl~G/IJ]{0|8/%φ4tm7. ý\0P(lF*}:HI{8衜BeYe#,@IYI0.ju8Jˀf\%!ߖ\̐9YCeu=2F࠼mbPdJp3ɋ(\z*+ Pə٥JFPn!ږz̃qmgF?ʎmMNgr vQ;ӭm]'[4H%5nWxՂ?J?&ܫ_ S !$H/H0Zoqa32?yNBqb%o0Ur{x8Ϣmmub4\^{6[R\ Wp113⦅Mdz- *>+{E{.H]sW7GаRJ8sjL鎤^8+ٲv=*%I˧&3:Z/0?eQX, CzAyS6Y>ݘD`W U[o:JʵkF*wWN>g}8KK? ~G, Lzb$q3MRc z)mWG'$gr0f k8L͛+/kYLPAh D`#7qRاL,T:&/;+])+Y\.vIN4 B7)[[yC,`K_UA7hPefqlo4H#5𻧎\:Yp<;3/-Fxxsaqsq*>ns}Џؿ[,8ٛn&5?UZfr%ZlꖝtiI0Dxռ0/$&ٞ6J!tev9l2)8į{8k䥏^-׏|D\\GҡC=i[a} VedKä$iݲ) Oh(9endstream endobj 66 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7793 >> stream xyyxSUmKs/;6fETKRU@RmitI'64iڦ @dG}U#*=fs,?I&9|YN~DTTT%3122:2*&[1t'|R< F˜aDtT祊F'gmM G/, ;K8;kNܜ7EyoKH7oYX\uQmKX<}EJգOM*'4屗_yu׆=;n$A!OK?K2ib9XI#V5lb-1@M%&7I<"H$^ "KD1XHL$WLb01"Lj8K +8{B~9$:rF2zmz]+e!6|oXt3O <'][s7GdKq=-Y4_prm L"yǼM4ҐiB.`?!dZEskQS޾5"pt1Žo8Ҥo}pw"̧of=' =c)F} (L Px}fȟ!056)!m8wg@=(^Ԝ?I%&r96Y@3#)t3d?XB&_BA.=OҰv: 7 @iQjߣzP#Ҹ۰v@yK tN[)[H ȸ`ԃ{'&Ģlj4%t\Nfm'c궜vpw`8hź-ۙ $B~1 jJrwjtKI1c,P.>C:ڍ!y$8)tg'`8:JY A #'%գP z,=S-@MN8ns)pS EUpEvx寀W) К5 T-aŵг< J&2{JDfv!%&(;Itru"0M“}TO_*q[8t)^"*FY J6^3VΣ13a1-os~[ r/,qd gPT@aH%M llAĒ D*Ex+hM PoBgp4:V5W9QANc28{'^+(6+mǴ3S yڬlͤL){WQTgkSۗZRŘf0%T[R4]X}7{=ͰU+J@}E+VXsn1mrxXAeЋEo5T T[) B"JWmԧ䪱ܠ߿TSMYUj7~04E*.E Q vfH^4xU@Iu$HM~6,uZ-plYlXFgZ3Fgܮ_4:BCL,^}TZ/1^Lcߺma6Q+K,@}2L1 x}]LlozfPNV/D&jz0I3n ڙPjW߆)YI@uz9#MZ6(3G[SM. (i [j}hQ' _ G=0>w7UGj7le%rD$l\3  7)>C twG.K$yl]֜U6QP" Ϋ ߦ{v%OKc^ŭa-vۋW׮^mS^Uwu缷>bk0U@֛Y 0CSI/D%֋qy*w!i쫃u@dpJL`~cUDVS l6Vҷ@Ey 4P/Pڃs x:N|Nַc"\'+abμQ2OϹ {CqHԻ+8Ak j̼Ey9&IȢkCMAnX0@ ;ݍʩkeTݺ%hc`t)ⴃe:ƝabtCILn\X S&Y`X"nTQMiW܉%:{uC\rU٫->d2D;LMUE($QU[c{+e Fcx_hJlSVh>hݍÙu:LEi,ᗜ*H*$yzs;c!PE5V ObxJ%2,eh[e $<4 naY zt# ?rYw,c3h zVup=.)~ɫ={3!2UR Q<'\wo6-r\bDdeG¡(BٿNkjf";q~>h/(>8p'GTٝe|Q8R:UHw,VtӀqKWhu`eR/(׵Oh;[,Wq;SdOXF#d*ދ%o.1 LL%p\GDuIh$\6`;כ#Qڣ!*@2!yvU4#;^ pK pN 34̃dp0Uj6^PKᏂ1b` F6L6`#LPN!'xĮKK&+ @>S[Zܒ`st_h|U.$ë\}޲Ȋ-oz$I֔PrN 5lۍ̴MKk~Ihs\v4p>&X<[%X3 ]!Ӆ W˶YRɰA3e'-g}) }X޿Z;XPm}NZ!Yi*WV{+Cb֎bqm4 3fPиVW7'ӕ9W${2ksMT+@$y.؁q&G Ojbx&mL{#GT/e1@0} ^ifl7c@kbI6dѹG2ŁL)wZ[|<ﰟM ԰rȋLs:*upo.cZTD+ mP+R㬵ոNOw\\lQMpZ@!FOyX};XB=`z>Mw֥x^Xo&rGn1jFXJZ@r]"T=BmÍ@ͽo4#{wANh:q^9wy~W҅~?ZEU)Nґk]yJ*3fP[c30q]7ߏ=aǧy I<Ѐ`BQf5.x"b_ g#me`HnGy,i7uA!.^_ izYf= -BI \u^GN a?<=6#G=!Z{qBsRvs7Hѩ,.(•_ȱ/bE¼#)oLJl>EIK 8=`_$#4 lw^oB.~u > }~ѢҌMu^-G%8o1_?[=0*k=x8N](-qb o$-ZrN(gڷ02Ҝ5y Xުa PupC~]qR c` cHڋ yg G'Lv@~(TW ~yG89z<8k8[tyo$Y=5&RKO@c&&1 ۘTCǽ2`Pdfw0An､/ϱ#Dë< L1[fVzZFR\y T(m eIrqMpκ 78Dy__0MHssY#tm\v0WKzJ.n]TlUzP,g~Q,K>d6>2_寽WO`o> JNïL u+b8s){*8iRN CZU(ٞE)E:Lbh׶~AAXӭPj|-n5X_ U(P4t-?Vgѡ:le>#_pp'vަE07 b阳xd +,S5#ДtAZ\3ޮwNyIp:` $4Ԯf|yFbB_t{ b\uqN7]d z|eOuH_ϩίoݒ)/̡ F=)P:e\ GA3(LYiH//PQiHrAAiA"GfWCSA+1'1endstream endobj 67 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1295 >> stream xu{LSWmW@T]ж&*쒽)2*A)ByDGWlKy ʂ0 zQ[6,sA]Wib?|C"bZnTK+3*Wb+K2ȱq- ;ߗpΩ=ս%mӋhfԄ<6㶰x'0x`!wI]A'R)T4R}n&š;$9 r 4$!K)ku \\z^tEUم,Lr$VqX*lm@9PoALݙ*P/㙥WG9GˌkZM^O̯MV 3>S8Lz2F|LVǥK7tXY7pkԺI;~]hk`]DG U,`5[lzkevN_zOz_PWzH[\XStˀV,gN@ĥZ[cOl Xn0t/^)%[s O6~%F1_'C QǠp9bOX*jˡJok6䬌7@W͔}zŹ?sS~m5.[Yn149fc`x*Q}TՏ7t+w5f{ma=82| z{4>B.*/xh; P8<~觻C~w,|egp˸PD3J١l9tTnj(݋BjQGS5 LƧQő,^ˡ)YvbP题.>ς2AM+$1Ͼ<ϑ|=7/\ ƌg|j,[)8Q}#o(~ 9iYqmGe*fƞQ, ?iٞȋx,[8x 1xtagۀ ^8m\:_-(HZ]AY+d=ح .}5OY42w Mux63aP~C|4Dendstream endobj 68 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 384 >> stream xcd`ab`dd v 6400qt~H3a.g",,ݹ|<<,˿/;#s~nAiIjo~JjQBpb^BpjQf s 13##{ |v34'?n}-).jHJHow[mVSW~Rۤ3J,T[o߮=u`cL(ٽmAMk}xÌ~uOoѿ^_>KY~KNfoڞZmʿ/~J FA iu))|e ;cɄ sbf#Tendstream endobj 69 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7652 >> stream xy|P̸&A"%mov7={/i$ "A*x{;;٥˜9o9EAdee.sŬ.[|§ [<|l3g K{1B"&fCG"b.8&1OL$" Wab1L 5Yb*1FL'fq]Dbq!D1&K&}D8"d:cLٯg7GUS{ӷ/ݷo>w{"˙[+א$w^y x{x[v |}5qw淹D_L0>@J,$Sp>c6E>lӯsdЙu`@sLاldMNّlQOPW踆>Z|'F.wt9 D24|9z^7Hhٍ0lD9^7Ndrn2 Ossb`5)E|b/J#m"R* jM6\+ȿ>}i,-j6qAOuZj~|9]ख़{m0c̞?^W"u46IŃ7Kh ʃ.Iu& W WqR72$dӰ;Sx`0Lk(ʺ h z~T=3h$<`3فK}YR,|Y|űtśh)W2kkwvjxCުEѷ&ѓh,@%2|RO8{&Tޚ.SRhr o?G!uNֶƯpq* 2fQuO“a.-.@%XR$5_ފ PYАc$рbIjtn /a|kdԛ {a$R7 Fu)ՔXR'د.F2b/U> A _G85" *n tX8Sܚ9W}^7w5i)%iTxӽx)X\xH%ԾZP7Ps)7]G"aZ 6C*u,ʅIf4"Æh^2 2|G/LY&Pݐ6R5"rPv~HZJ"lw-e0d Gc}|Q"{Y9`*ޒ[:O]53d>1+LFLrM4h `Jt@;uֵnhiu٢QS Ve`Wʝ=<΁zzy`A\xfִ@<^"KgC&-)MX+LJfmꆍgS%o G-,~_Qq(=]VH84̩~zFA.k `d,ۚ`C5pժk:iU| $<FhZy`kl?deH/O x#J, I%GvVM"PjYXHa7 p IX[*CAbLWq,mid5rtUav\vW+%#Ԙcv8]x0O`v[atV R62сcލ*bLr|܌1 Jn;0$6TV4C ~Azւ:+^ n%pnCf]WS$5P,W.ݯ -4#a`?8>17^&`)2)4TJ̮sgxǞda#7D*0j"'0HfA.(GԋkR[j`cLJ{8 ,"TS5ݼYDꝮ s E'Й^ $"^$nƘ%.ZJ1amm&#o䵎iSha?r[|66cLFn܇krD(WEw@L&8k^юygy-df,j+vFM`;gosA2t'R{IܸXr>B!8PqP\ ԯR(K4KyGȸH jIᱜP.R}yk̂ڱ +]þ^Q܍9bBA@7lmn#2n)I,Dfqp*|A$R66GcMVVNG#yS̮ToL8Ud]oﰮ%2EfxW`d$XF{qW"8-Tz-l[-&fqܾ:?M:0Z?4㉌sr/+H&RMwq$c-T_#W 3Ϗ.ohՌ殔+l:ݝJջ}RAo&/Uz}T}t`7 )j)Z~.^b>cgs!=j 肙S^i_E)CPx(/,)vd7dIB%kykvDmGD vk,¥mT+1irOL8C7#xmkI@@<zW|1vixNL2+ula?@{ȃ ])@KrXae+`A%|=pm?sl Yy-7V[hW`( (023r^z6wR`eim$[Z6Ovf]uM ^Z`\ZdQ\mlDxaqcyӪ("AD~EȴOMMCƼpL髭ӥ]hyddwGl[\U9X"XtK(|^s˞s%1;(rd,ZN=>_/<椑1"AH~AF4~QÉb*XPxJ]*o1<srڎҚi\W54$D&z Ӟtk8K`6&<2 ^fW/Λ?hNGl'+޹=(/0;43ʢ%xY٢iku҉o[tͪFb79#V/( Nm^YbL$bẆ& ^x}d|cpNXYRS.U_VUjqmy-:jޒoFr}Cx8FI0\qܭ $,MIpzNF1H_h'},Ӫߐ[+StsW[vi:$5)X0{j;ZO5kifc=?)^^J؍ i;4r?R,M#`?8O,u@1fYo; |(.ʁiԥm +,H,eNFAl`$v1'*A %hUjD*%ZX滄dm9f'tD9Nm2þyWRSF4?'6:oaYeޔ>'^. je>^[":7=6Kwj MqFqrSE)GNKz)\ s\tY,ek63IREIT;${Q s/Pաh4\Ew~iáE)mm2%)H^8BYb "l˰EuLM H1SJwYh51)Hn۰J]-'źTABV *n'{+p][>L[2o&)W(e*oMG"LaLM*L?8TnUt?H EZ-CVEJ$Z' ̱u(y뀀y_$ 2j{2dBx88G\BvlVPC"9%Ls+xZuC^_.az)?<j7G/ LL7| eN鲽|737ھ^j[m4Wl;L5lǾ$ KR ߌ jr m ߧO|:z񰫑c6%1˜Tb-\;Y HkIzqn*ZYF_'}E80~z6L<# IfSF%!ǜ o6 pM^ʓ5JrҡUߣ_W[.S5iBJ犿[«!o&M ăzmPhh05[â,> ߵ 傪jTSfU@L/Sy 3ruia3}g1xd#kz Ce2''L,-n_iQEg<$B=c>խ $"?`N ʖz@uͫκIѵau3 /-@,-[Z&?75Wbԉu'QѳhhB^(+8ԯ2av_fW]}}8!E@%Ot-xX"TP> b]$"X j\.8huMm#Sm@C80Q颲5KMK`o' Ajޮ̵!7E|aL<޸94|Slas|T],,?S  R)+oqM#oKMFb(W!(y35 q ~^UdzLuK7Իxh%JDx&N0F8*t`Y|fŝ.%'uORT+Lmh؎=ɩY/_ǭ4zA mb6-$s++`ћ5\&>8=jG*~ʰY@bWIǧbuyOǻhD ͱH;<}9zù.|)TD?dci}~ l]1cA$i@ܟ9p?HC]A:QwF>ʢ.Ƀ^'9$69rW$*7^ dC͔.Xl{f@gʤg^7~@3u!X/x{DY$^kIbQ8vIGv:')م//>}T͆)h7[+LIpI9 ɴ xP @h5eč tQњQӐt(kXtӞίUhkyTx$~ct-I(\:7?~xF$'º0<\yuGa+|w,zbۙA#džh 9kGp/h:yj/.xmԭ8%䅎CNt:jEs ; ,i}?Wc}xO 7qS0y~V@F8|n;d9h;dvztRƸ8,}4 ؑcWn-cNXK,%sgm-l37\NP%6](8{%0lFDq:D&$EU.?/~áp 8  QCA:#`[dfZG@Lʬj N+9)[`ޢ&fTeqtbI}ӿcH/tKUj_B`.wtFpaJ0K'3j>Y#N&BXPZy՞7tI+lCAM0}i.>}鍝 Eqn&vg"D SPg^C =t= Lp@0,u<܃ggw20#J$I ddEFx EV@5;3݃ '_rwٮ ~?8x*|Jb >u ^Gׄˣ*"X&C:Uޤlh6P՚YJ')@w>ǶGׅۣ@ncUJ8P%eA ll6I>Ot 1;`&TijBN2*R4:[.^#-|:Ha+VCw3+@nNGnuF R8()w~ %5ܿQVS7@8dVed$h7 ٻ5D7|K"޾ll~ b{aendstream endobj 70 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 446 >> stream xcd`ab`dddwu041H3a!O?VY~'Ys=yyX6-={3#c~is~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWqr-(-I-ROI-c```rd`Pb9fߏ?w}Wk>㖟˘4mXZ]՝R;֚fn={Wuo>ܽc/.N=}S{z~eo5V¾Wۺ7w?^VllW`ѽǓ]տ+1S(-C;5by-}K@{ شl| ~L`4߱wq}gb1ùyw<=<| 1endstream endobj 71 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1611 >> stream xm}l$\Y' -ܹBBG F!mS PYĊg;%=~w؎_b dKJ(K j&T&uBs1izG 0޺ҭǥuzUhXg֗J?2N+^ <MLv47hm~zǎ훴ۺuv4u6m6:ZmFS[Uci-[\.fm.3mیFvFk_YUWZN:aVqzKˮv->iyX9V+$Uo֢giQK ΣMKۮސD:| \hf43 omA&#%Ϡ j6i:";HcBy>v Bi; ቃy1BeH 4vQ5lv2=2ES@,k:'& }@%) cx .Eu (tԌmP~?+X 9.IibBha.T[.B.*gx4pJzY 0[uoF[%r\%WnT5Y 6pD\xi )aݍ bLuSgGμ;d;z 7^>5!F& $?CL!=~p0H%C;0lȅUȭҘ/4+vyu {Zv2knÿb?!'B|8@D@ذ TDBl x"rhR3*tukr։SK0L5OV}RTp~2^cY_qI>?ry#Mf ~8Eȣ"ǥwUR&2bTPeg0P[R#c枈J=NƀMQi6AߪV8U|ΕUIIj1+JdtD J⿤L=W4{E*Of 'yY%{u@X|>r~`pyG\AE։O SIO,izSmOf|_5 =*2Ĩ{o//]{RA8\ZnHe\]vɉ.p:[ZJ)Uݟ"j: -,֬c[I栓P9$=$+|*rkkX2BcoiV7?80HNMႽ K|i}ɁQj ^mK'Ǘ.[|"%Y%N`DGTNg~a?UKP)g'3q_TWxr֙@,NywBʫBIL8qzTN*EMmfkkrnDbYbYX/^Jnϔ=4)+ðdiCendstream endobj 72 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 389 >> stream xcd`ab`dddsu0~H3a!Kg,,ݹ|=<<<,!={3#c^qs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWvt-(-I-ROI-c```td`Pb`bdd+w?\3XBny}wnwNw}w]IwuuTt6vWusw_ѽE<ʇ;,'O?QSX >}I.B ?\?JD{2_Sϝ>w$\߅Xp]x1oendstream endobj 73 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 760 >> stream xM]HSqgsesˍQRF.Pvlf׎)2tGҢ. Ҩ. * H}ny~ IaXGIieW2"*DŽX.צ%/7A kv3֤˄{-ÈFUpI|zE[P|[UU8E)SC|J|*$yWl۟X$_*_%~-kfU_|"!]0= DHB0Ff+3ѩac{ ƵjE:Qqt&B ^[^Ψa~\5ߟ=}[TLX{*orw=rR𒫩 N /x wVܹFiu}=?2&XcO46B x!~zÕ?PuÇjnlfW{) iӏQu?$~(8 Lqq,KsY3_tmaTPyW|{IlN)h>ob10\Nj[r7PVn՜ZȇSMݠ쐻c([u=&n h}KkkKڢA't)PtGO!-^5¤X3:PdHդWs|0gJ1$bendstream endobj 74 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 634 >> stream xoHqv9^D3M2^9mvvvsf_i٘6s!傢H F#!0DBM<<ϛ<f! Y{-c,QB>%i@R"wlQf(3yw<|=i{-2fg S^Ue+e** :tdN'v3nQW[,$92^pՖ2Gt3M\nrmL=Fc2eayKηq!W T !dBWHx@vy J Lxn[#pV(ղj, j qplVꊱg͞e؄ "Kɗۣ'GX: 5H]N Sc[Jqfh7]laQ};MKy,ԉ$/S:S${W#`WPo@-tv7?_$=Vmkǟl\g5E(c1'uGo !>-B7"8it>:hbԁ}JMP7endstream endobj 75 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 442 >> stream xcd`ab`ddds 4H3a!k_VY~'YsyyX^(={ #c^qSs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWvt-(-I-ROI-K,d```b0d`XȢG/e{3`YLtKJ`...Z=GOq72Zea'.='㷀oߜ3|.;ہ|gWm,8P7w_|4[oti<𝯛%mm[}=9-DL~eT\~}s+^~ o{pļ uendstream endobj 76 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 405 >> stream xcd`ab`dddwu041M~H3a!-C5UApnne?x ~^!Ș_29(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMU8VB9)槤悌K,.Id`````b`bdd'úG2,w3ʰ|E~ZĖ=MwH7ǟl?&x9iro_~ J]Y΃͏nE.>֊c okYe~'twuuvutWt7X7CϬ?ۺ$tϕ+&r>.]r\,<'1/~endstream endobj 77 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 938 >> stream x]_L[u殺]bMɽw%`CEb`-IKA^JKGܞ-IGe-J@ ƍtN̈Ɍ7~]MbbNr]_hjj_lhh_k:@+T>^e*-FӚFWL&^ggkhGwhne &]^K?Ƭܛ=k6ih ١ k:6dc\/T uT. KDpN5vLzCT|#o gg LY">In'>ۊYV4@ :QZTyЪT1,eݹ׃Xn { 0!&>7g@l1ҷSƮ/2z7"~ ڗaAaa̔Ct6 ħħœs7=(Zm| 1a;RyJ[ޕ!JQV{4t .f^Be>nt+yK2UpD=vP!O?d ,Î̹RfyYnml?vLuHׯ-CvӸ*בl= f!ysMlrE g)QȡѽwHur ?NX^qrF`% .ssSxo<w|> stream xXytTU!e"9ba,b, =U}R˭}߷T(؂T(p`=gԞnᙹtϜ3̩S9{~~M 5v URR2fyMg.r_rLR1+)|syE jJբ?K&c{naZ9MNSRcJJnC ee{}ZYGD-m] pEQiX&vmn]!Vږ{6;9s|wܹVSkT UKg%Խzj)ZNͥyJj5ZHMQQ QG[)RScn-+D Z ~5&p&x&|5ION:3_'yË:Ib%4 MB@Rd!ML̟IB2f#pig:ݻ=}z8w6_~nm#ղy|/)lp\a%~DjZɴ؉dk˰XF L]= @ERWfUDJؕ0%{(|rnAwa+I@*׉goX NRin+zli΄"$bnf|8wyvw\{~/lK*ӹT:G;9GvVW7?h5Ux9Z/X}&nzX2[F$GV<e={-6 2ܽ:xwqӾ7#mHi2E4( )wrX3 ~S5UpM뷦jhnKўQٌ"Tߦ7ch֗N~Uc.HʹxGKU%VEc@-g>׿%[$nڌb 2v+[1weBD>|Bȸv&A1> g֕>=RӠZhM`QC@D#h2Ւ'Ke)WKmwۻQ7Yu6-d'g7}rpgIC0EHEi*ڡvfw&I@/ 5z\׼q S4{r ]-l~`9}5Fyn?Dx?g&dQHA&H]2ȑv6)z9}ՆC} =nǤ:$"x5lQ8(nH1>0{,;c;,ndF.VӴ}<M@&,M|vo@2OA|`T֊a3l1=ye*h y"̱~g.G py_{Ž?( >DS4bO]k*nWilUgl*K9lI2JլlU6d BAU.D/bإ@Q1UžB(x;||- on&5[2Nҹ6DAȭJA]>9D7]g$`/!/#([m"تdKiqD{{';(c경^EP1 nbVBN]GJ &F'Lz;'9l Zv, {#dK/>h'LNIVMTHv_}sTjRȔ{WUS[N0Sz?|J5g :~FЌLJΨ)Zy,)8Ψ#Qa1Bs#Cǿ>w$aƩwBVYᵮ|s%_ ᾳx.@l"8sӖ,@^l٥{;x>bt@ZټM%G`<6 gΟ8[ 6k}F_&b ?]W"^6f $#4EJ>\L<&ܗ@Ff?n*;B(djUtq,2X2.|WTRס@{DkG/<eYu~U>GM| fZ-ƴE@^+.68^3\9HZaU 5|?!I\Y $:RSŬ >R``,h>pv~+ ST#BYC.Rh\yDd@ Gv;=+N hEfG/H侏MbD(\zsNo{ 3jDgF'ё(t&{N%+J]jon@..g.'1s^]7ŵK\>-߁:fZ~Mg M$v<"O(H*b%(ILaJ$JuE! !,v%." AG*ĕY vfq W‘6łt(2FU, UG+;}*=̉J]Vy@lO<^;%Y]2^,Pq:& i3g$yU$A,JqLJEJҽ,0uZ# -&ЄxBƝueҘw vCۻh mԈڕҫqboJ^O۴qN-7#1RQ+=f5fE#Rɜ&Jv^%ɓ@^^aRULUGMR[ BiPO__1ꇟ_mcz:aJ$ֵ]y49xx`鵩*m1/ ,O'cEŰ%1@7@6HMCj+߻}.pXFCR8wDə0 SJ^ձ)V'oT%AagyP^2ֲ2B'K^5^a?^g?ts;sm^{;=M^xq_,QT1Z3jKn[Z_hƨ2Zf<"?Ӛ1 #Dc _`yǏȃҠ"T yr\߽t˚&^G]PQi9x{ao눓 bƿa/G\Ϋ  i\3g7 =3)颚%W/^5W=}=> stream xZ[GYOH/5PĤEyH2+Zśc\1@3ӧt|_bzCz.ܗ3?;|Ε*sm)mg/-Z1Y|?>[O%g~Z#Eņ/FQd(sJ;]j=4] dJzVNdMub20P3Ϛ?UUKo.,->Fl<ңf+#6qW&PogND|x^\Umċ±nT$s$GۺlN1>xkku)5fOh9㍌nʚfT$2d\KA?bM?l/Ny»˜*\nV` \QDŒXծg,\5 c]ź>WmhXG]^`aƖRy@,0}=2h*@M|KrFysܭ镖CpGb*45pۜ7-8+= !:yYׄXUMtš|9Sc@AfabgPֹ҈^#rûgrb4T.댏)U{R|jǶj7.67uEgj6l.scXy3+&RCdVyoҬVPYž9~NlWsUN7/#}s,7Z̗1?1Hy'ϩ@6UږFN3_x2ؗ;%I Pc|u{3Je{bY ;tuq쳙#:vU:l'w@2 `T" !9ixc,+G o+j+ɱ >J~{!(aGm W VrʺKY'^m AOU ˲[-=G掐w{*a;E j_[I_ >x5QhimjkYխ+; {^O .Qi}v-&&ˇ X"6`g zP`1dNX~xv7J'EUaCIfQ@ ww)XcjI5I'%F P?ndDM;b } L7{Q`Pc$h%'EF(?T*3w ced] C/U;ȟ;@g߷t)4;Z6>GB[QRe:/jnIWUo GXNo:%ev >oѠщeupĽ7?rCptd@#ކ Y*4xu~sxr hMv}+m/Iަy|ю i "X5}}H xcD]U[ bm݂mvO򭞡L/2AC\jx'k!P >endstream endobj 80 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 413 >> stream xcd`ab`dddw 441H3a!3G9,,ݹ|<<,+8 }/^=O19(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMUSB9)槤%W&00001H20,cb`fdd{ڽ7gg9^\\wˊR yucy?ƾk3XZ=<<@~endstream endobj 81 0 obj << /Filter /FlateDecode /Length 2410 >> stream xXKs뾷=|Pe˜ZF.[Hr|R.$dI&AT{ʰJ _wϧIIN|uOn>qvW]p=*ʈQ'\71fB=y圝Ngt+˺R9g4ΤYmU&+ nvUwu{bltH֮59j;K#x減\::~LqkMK5'+w] 9L+@_w*~ݔzYwuo¨K1Ѕ[qWӫ>TX qK޳IR—ֱ{sY>[vMN+o_p^tl3wˮlvz-g"wrjd<}ߟWz`_B\Y .o,wEƭ+ %I(hqx2X$~2NPY-L>ZV謼| 2SO ;*7ExH5<3{<6BQRq^vE܋\D_R \YxC٪6`tn/>S4/$@ ۦj|uu܄0 (ݲ$lܰrSZT$:撳E8n'̤3M&464",T6j,pVgK=OZe`&)dcv[7#QQrxZQ4u{GCzH [(؂R+P(\.,!:X=x›S H]7v//D"1y\65'1HQZyu*dQ<h Z`'NΪ1W~ZC41ﲸQ{7HNaX))L6cvm@sK֛klï]O* Qosg3;U@kfJ8 Tř?1.A`0ͅ$`uY\Si;QnzN"3b.N-e΁Pd L[#%@bm^l>R8+a_ *vI?/1:xyh`^W1PxŇ_mKI_XBAzdpIr0ٿPMEqS_y(zGJ@3^S yz-*7zn|PmRU4 jU־#̉>a񜧼{7$(@1Pŗj)3׫rekj?]q2L7%!%0sOO罤L~[okl}h4} T6U|Frڷ.i`̲SPA]ߨBK0ϫX!h0bn~F%^R~xUZ:?( it|vylT6l`/b U.0$0qdOiXū1b,x&w]~}zf- v5 )67p;M_ۻr5fK6Qej-і`8݁ KU0(&3sOgCTh74Nzוb&| B_ҀJ uB .z$;ԫ5ڧ PAOe]-%u %m?*^}\i\tgo~'[^$aօͼ;;S8C|Z|.}I4Sy3g_Q9%5i7-LsL]UDuG_ VmڥB#(Wvďv`1rÑ`Ԕ=D</NR;8 -BX}1bb0"G.D'Mz!Õ1tQp#i$Mr{m oyUR m_qġR]F%"kNj05=nSο>%8LPb=l'Wc/ݦpE_'+CKS"蟗_h}pspnVtm7<[}qu7endstream endobj 82 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 703 >> stream x][HSqd05w, }(|TBII3ye噺os]bYZ EBэH2z8A_CQ$ɘs2322v1.E8.:;1V%8!E~ڇpb<%$y03Y!oK+i"okI+*궆RqABE]#AD!"bA/A!m^Z%W|"ԾIgQ!'0b(Á9 Nܒ99PmG*.aGXK,Lcfx3Rk0;Zty&tN=}\pxE֭RjYYO S x}NhX+W>^X|@FX0LnF*&,ac"饼qMjtr==# BJiif\IZ m8Mjm. ݹq1Wh=jendstream endobj 83 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6713 >> stream xywtuhl+"cvfi!B. HHwz1N8N&|uɲnʼnk )$!$@].s#8oߞ;9SSn-yx3HOU\ >йc,NE-?Y1`뛴mU-\ѸK*vWӷ _hzeQ6}+VUfu7>PܩX(QܭXXWN1O^A1_QqbbbbEŃ))(+^V,QY=? ͳzխKo_s^0E[>M]T*fmƿUsؑ˿>;OW~j< jn#6Ano+;02:x/O:?Xh?E8]~ 򼏫&ߺ-:qx+}z\_ݦiXm .gAi<t8sLe I xo5AeCΩŕGY1Q+ق|ٙBG>d; wrЈU &Rfܩ[LZq5[k,!''|(v6-{m h@^aOO$ 0+{vuW󚭀wd]zL+^/lYni&b zǽ3.K+/LwKwu""x{^GeC\Ծ*.*߈h?y(C ?<}Lgrp;ѵK(ToW(t_ _NUNX_s5=J ݂K7/)>-j?Q":gE4f\uvοotw.q;*Q%9w,sFxHn.Pa?N&8 RӰpH:q[XzmyGwU6py&yAP½(^!O"<4x'3T;ȇL>T2);132qs4 d“GzГf=1BωhI6$q+v}522ÁxF΍T7 ؖ.p.9GQt᜿}ԒsTGyL?:<{]L .Μw=B3Q:xdS"`pp8դC¬t49u٣%%m\PdGxvC2Tm,GݧofX|ɸ:5z'ܺn[ /y _ ω,#P}Uڡt !?"FɻBGu*"BShqCĘ{myvCMs`,=rE'A":xo8sm`EҠrzSԞW/p넬7nC{O+:ʐxx:;F,N=|7\@UT8vm Iᄀ`%TNbI7"o 6*RȦ6qpeu^ah!rDZ$Gl|@R <ӢAD +UImqJi}!bAf(8@M*9GBNĈu@c:9?aدN3.z3]XnC] 5OH.vB'.(=[V&v.聱aC5ZJo6}gVm~귫4KKbK;VoC@Qx}2єϽeϪYmwUBH$jаd2|Jё,Ɔ$yn9Tʡv3Հ[<.al`0 ^#ᮩݵsc&%_GG}(1<wpp'+YGKYȫX"':?L>/[&'nj/7V{ ғέtGuW?;M0?ݛ4aX;͓Nҟv;ϋq T w1)X#<"cаƏjx&wkD3鷛nD2bI2h^.꧲xLa~1ulW83WD!KD*-^c~.ĞHNȑ)JX#&V"KҪukЯc=#pBPoA6O h=xʟm<<~ !>{)l5Hƥ жGGzFd>릱xlUFO=vS^'p;=X6\^)ͺj0.5Z(a *k SF:-BTe"΀hŴ-dg"řy]d, xOMɷ Pց,|\oS|GAGCt$%j=Z;9ܥI!#}p {*lB5 ]t_#bg(<mtF" -ځ!L)|L\+ fY\5(r3f~Љ+`lqq; ;z:W|>:^RH]lX_ƻQp\ *U՚XuܧbUfb x)w+U-a7BkUFI~AkP} 0c/ˁ[؞i-.8+>xi-',^5_ŏހSxsUJ`Brd[Qdf3̧ myF?+;&n$l1cK"[/6=yȮ֚E[=˽ɥdpփz|@ #+wA"6}w:sݵZ] +g]K. R'3M"dgem3vRB˰D7„`Ӷ͢oڜnԋLSܴ 6Êҋa_!89O)5m|j2.h5L *d`44I"}y?|Ϟ JeU\~M5!cdHHHt⓳!ŒFZ7FM"-U Uz1M/,H8 )*ewBEٸ[#mZK &0riI!gD9կxTy> s A7M8z`;u4ʧ%Dx5M@@ekvhunzU68J-coy  &-~d+{?ɞ6fMKl[^^;!$ eR_=nIe^?ACNzTGN> e] l`jʷ_P5v(aS. 9ڀ"ThkQ0v]V7E"l-a=!!IJ; $A#H:w~̼ܰ¸iTlm.)n\Dž*b?^,a}SC!6D=EFACsKާ3<%/.ŚjiN^zC iLF7z _& >n̝EL6>%yڥnX+L;Vyq,-.օ7b>ePxS,D3p6b|@(r}2V{MrXlUU¯a?5/@۹#.K HL}x[J8n Dt:pG%Xo9(gƣCÍwh;F FcaCm!Ch-ga6^$U;SjVZ h+۞v(qpYes4x/nB4Q:ZXLBn  d Kǥ_yMq QP`LTY,T|rO+GHYxwcUP嫂Vh qj5^%$]* eQ,X Gf8sxSx}>diT%1G0S,vE8,N*ItYnvQQ},~/n7ϓe#|9q~`d+pm./uʗ_csAF'$@;%P}b.D?.詯K^,g7}*_LSR{d: ✚7넯CԀ ~Ļ' !|baR{I+Z(+Ҍ]_\&̥LWK3,Ht|9OD`CxftRc;l/lCmn6+['5WĠ{E<3I7P'Qh0^< H86N!jOTWH3ڥys;sD]˃;iO < 6Zt)E+8i..627gH&n$ջj}@38) Z4f'zM ^tP$4Rf]hŭ{</p oI1>"?6.T7ܸHכ)+M|88~8d]tKX*nrE`hLOLF [v{S.Y^yQBN<_]vysT-^?Sؙ\e)>i^w=>5yN)_b]s9uXTѪCeos<ĥ1Zl/D`]]^Ng}^^<#6<cGA1m??Kr=BO˪..Ohج?HuǶ'kUW%ҵrYXpe淦M,R^!xfot-RkLI.pß$MOL&jo+ zc飝"؋OM#56_G;j)ۓ%TDBV|mzx@?5 Vo^S>™spYZJ*o G}vySh'᫧!zOL䰸$(9wcEA,Yt͒rSצd™%=g7 6d$|rޣ۶$G>Pip!cT GOGڔ֟KzRmzrIZ` ${` +xk+(jì.͸<g3|t?y>n7 Bg[6G|Z*$T[wna#!O|0 DѢ2ۉhFUo힩[.Q]-FBF*Ϻzn9)7[m[ }Dw~?rÚdb[,Bpj '*K7aрb,()`T !ˑ5M9ngΞ)D<1(dIҲ-Pۂw?o,nj}{7oSԫ w20Aoo񴓿lԮ"@)b3Gc\Fr)Ÿczaߥ_ p5} u8o78"/KC?=H?i:^1p/52MT[X /q&ڋB-BPD`W$1tBIG1nO ={m'TC#nWڗvҭ7w*;rp&. AtL\0NMLseRo,~ncuDC~|d;7CzlROJʚw~7U sz7(͏H9i>[i t2L<ߋ,kzCH M!n (Ǐ0#($ et7 [H6r [)aZN18}wT~H-:9-j4 200OaB C*9d j{@> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 85 /ID [<62f6274fa2a40c2eb0a01c2783114acc>] >> stream xcb&F~ c%0'XC#Hy fF ! $A/ !Hf @B)Y bi A\aH0 A. bmRMz endstream endobj startxref 60132 %%EOF expm/inst/doc/expm.R0000644000176200001440000000047613777326457014075 0ustar liggesusers### R code from vignette source 'expm.Rnw' ################################################### ### code chunk number 1: expm.Rnw:49-55 ################################################### 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) expm/inst/po/0000755000176200001440000000000013777326437012641 5ustar liggesusersexpm/inst/po/fr/0000755000176200001440000000000013777326437013250 5ustar liggesusersexpm/inst/po/fr/LC_MESSAGES/0000755000176200001440000000000013777326437015035 5ustar liggesusersexpm/inst/po/fr/LC_MESSAGES/fr.mo0000644000176200001440000000216310743677313015773 0ustar liggesusersT :8+-+YO7S88M`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 %dinvalid argumentnon-square matrixProject-Id-Version: expm 0.0-1 Report-Msgid-Bugs-To: POT-Creation-Date: 2007-11-20 13:46-0500 PO-Revision-Date: 2007-11-20 13:56-0500 Last-Translator: Vincent Goulet 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.mo0000644000176200001440000000220212412743604016317 0ustar liggesusersT :8+-+YOFS88#\oLAPACK 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: POT-Creation-Date: 2014-10-01 09:33+0200 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/en@quot/0000755000176200001440000000000013777326437014254 5ustar liggesusersexpm/inst/po/en@quot/LC_MESSAGES/0000755000176200001440000000000013777326437016041 5ustar liggesusersexpm/inst/po/en@quot/LC_MESSAGES/R-expm.mo0000644000176200001440000000567712412743604017545 0ustar liggesusers )32Qp'&>8+W63; &El/$ 73k s77(6E"|'& >, k + :  3 ;@ &|  /    $& K ] 7r      'A' is not a matrix'A' must be a square matrix'A' must be a square matrix of dimension at least 2'lucky guess' was better'x' has negative real eigenvalues; maybe ok for %s'x' must be a quadratic matrix'x' must be a square matrixA and E need to have the same dimensionInverse scaling did not work (t = %g).NA/NaN from %s after %d step.NA/NaN from %s after %d step. NA/NaN from %s after %d steps. NA/NaN from %s after %d steps.NaN 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 methodinvalid 'method'invalid 'preconditioning'logm()logm.Higham08() -> (k, m) = (%d, %d)matrix not squarenrow(A) must be >= 1reached maxiter = %d iterations; tolerances too small?sqrtm()|| Tr - I ||Project-Id-Version: expm 0.999-0 POT-Creation-Date: 2014-10-01 11:20 PO-Revision-Date: 2014-10-01 11:20 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); ‘A’ is not a matrix‘A’ must be a square matrix‘A’ must be a square matrix of dimension at least 2‘lucky guess’ was better‘x’ has negative real eigenvalues; maybe ok for %s‘x’ must be a quadratic matrix‘x’ must be a square matrixA and E need to have the same dimensionInverse scaling did not work (t = %g).NA/NaN from %s after %d step.NA/NaN from %s after %d step. NA/NaN from %s after %d steps. NA/NaN from %s after %d steps.NaN 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 methodinvalid ‘method’invalid ‘preconditioning’logm()logm.Higham08() -> (k, m) = (%d, %d)matrix not squarenrow(A) must be >= 1reached maxiter = %d iterations; tolerances too small?sqrtm()|| Tr - I ||expm/inst/po/en@quot/LC_MESSAGES/expm.mo0000644000176200001440000000447612412743604017342 0ustar liggesusersL:8+5+a+)5@7Z'/!&2Y kJxX:8W+++)5>DtK' -N3h& J     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 %dargument %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-0 Report-Msgid-Bugs-To: POT-Creation-Date: 2014-10-01 09:33+0200 PO-Revision-Date: 2014-10-01 09:33+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 %dargument %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/0000755000176200001440000000000013777326437011664 5ustar liggesusersexpm/po/expm.pot0000644000176200001440000000433212412731331013335 0ustar liggesusers# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the PACKAGE package. # FIRST AUTHOR , YEAR. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: expm 0.999-0\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2014-10-01 09:33+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:36 expm-eigen.c:214 expm.c:307 logm-eigen.c:219 matpow.c:23 msgid "non-square matrix" msgstr "" #: R_dgebal.c:60 #, c-format msgid "LAPACK's dgebal(%s) returned info code %d" msgstr "" #: expm-eigen.c:64 expm-eigen.c:72 logm-eigen.c:68 logm-eigen.c:76 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:122 logm-eigen.c:126 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:203 logm-eigen.c:213 msgid "invalid argument" 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:164 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "" #: expm.c:167 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "" #: expm.c:288 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:302 #, c-format msgid "invalid 'kind' argument: %s\n" 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-expm.pot0000644000176200001440000000360012412743604013537 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: expm 0.999-0\n" "POT-Creation-Date: 2014-10-01 11:20\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" msgstr "" msgid "invalid 'preconditioning'" msgstr "" msgid "Unable to determine matrix exponential" msgstr "" msgid "'A' must be a square matrix" msgstr "" msgid "'x' 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" 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 "logm()" msgstr "" msgid "NA/NaN from %s after %d step." msgstr "" msgid "NA/NaN from %s after %d steps." msgstr "" msgid "|| Tr - I ||" 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 "'x' must be a quadratic matrix" msgstr "" msgid "sqrtm()" msgstr "" msgid "NA/NaN from %s after %d step.\n" msgid_plural "NA/NaN from %s after %d steps.\n" msgstr[0] "" msgstr[1] "" expm/po/fr.po0000644000176200001440000000553312412743604012621 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: 2014-10-01 09:33+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:36 expm-eigen.c:214 expm.c:307 logm-eigen.c:219 matpow.c:23 msgid "non-square matrix" msgstr "matrice non carre" #: R_dgebal.c:60 #, 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:64 expm-eigen.c:72 logm-eigen.c:68 logm-eigen.c:76 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:122 logm-eigen.c:126 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:203 logm-eigen.c:213 msgid "invalid argument" msgstr "argument incorrect" #: 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:164 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "la procdure LAPACK dgetrf a produit le code d'erreur %d" #: expm.c:167 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "la procdure LAPACK dgetrs a produit le code d'erreur %d" #: expm.c:288 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:302 #, fuzzy, c-format msgid "invalid 'kind' argument: %s\n" 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 ""