nleqslv/0000755000175100001440000000000013127410453011754 5ustar hornikusersnleqslv/inst/0000755000175100001440000000000012513245426012735 5ustar hornikusersnleqslv/inst/iterationreport/0000755000175100001440000000000012513230477016167 5ustar hornikusersnleqslv/inst/iterationreport/dshook.R0000644000175100001440000000122112513243175017574 0ustar hornikusers# Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 library(nleqslv) packageVersion("nleqslv") .libPaths() dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } xstart <- c(2,0.5) # \section{Report for the hook step global method} nleqslv(xstart,dslnex, global="hook", jacobian=TRUE, control=list(trace=1,delta="cauchy")) nleqslv/inst/iterationreport/dslnsrch.Rout.txt0000644000175100001440000001111612513243315021473 0ustar hornikusers Iter Jac Lambda Ftarg Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 1.0000 2.886235e+00 5.787362e+05 1.070841e+03 1 0.1000 2.886754e+00 9.857947e+00 3.214799e+00 1 0.0100 2.886806e+00 2.866321e+00 2.237878e+00 2 B(2.2e-02) 1.0000 2.865748e+00 4.541965e+03 9.341610e+01 2 0.1000 2.866264e+00 3.253536e+00 2.242344e+00 2 0.0298 2.866304e+00 2.805872e+00 2.200544e+00 3 B(5.5e-02) 1.0000 2.805311e+00 2.919089e+01 7.073082e+00 3 0.1000 2.805816e+00 2.437606e+00 2.027297e+00 4 B(1.0e-01) 1.0000 2.437118e+00 9.839802e-01 1.142529e+00 5 B(1.9e-01) 1.0000 9.837834e-01 7.263320e-02 3.785249e-01 6 B(2.2e-01) 1.0000 7.261868e-02 1.581364e-02 1.774419e-01 7 B(1.5e-01) 1.0000 1.581047e-02 9.328284e-03 1.213052e-01 8 B(1.7e-01) 1.0000 9.326419e-03 1.003283e-04 1.400491e-02 9 B(1.9e-01) 1.0000 1.003082e-04 3.072159e-06 2.206943e-03 10 B(1.5e-01) 1.0000 3.071544e-06 1.143217e-07 4.757203e-04 11 B(1.3e-01) 1.0000 1.142989e-07 1.144686e-09 4.783197e-05 12 B(1.2e-01) 1.0000 1.144457e-09 4.515245e-13 9.502885e-07 13 B(1.2e-01) 1.0000 4.514342e-13 1.404463e-17 5.299877e-09 Iter Jac Lambda Ftarg Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 1.0000 2.886235e+00 5.787362e+05 1.070841e+03 1 0.5000 2.886523e+00 1.211981e+04 1.533192e+02 1 0.2500 2.886668e+00 3.346737e+02 2.454656e+01 1 0.1250 2.886740e+00 1.860606e+01 4.931671e+00 1 0.0625 2.886776e+00 4.468205e+00 2.514779e+00 1 0.0312 2.886794e+00 3.097106e+00 2.281039e+00 1 0.0156 2.886803e+00 2.888770e+00 2.240182e+00 1 0.0078 2.886808e+00 2.864341e+00 2.238756e+00 2 B(1.9e-02) 1.0000 2.863768e+00 1.026894e+04 1.410555e+02 2 0.5000 2.864054e+00 3.038612e+02 2.346774e+01 2 0.2500 2.864197e+00 1.774832e+01 4.936364e+00 2 0.1250 2.864269e+00 4.259875e+00 2.397912e+00 2 0.0625 2.864305e+00 2.987137e+00 2.220967e+00 2 0.0312 2.864323e+00 2.822740e+00 2.205520e+00 3 B(5.3e-02) 1.0000 2.822176e+00 3.640971e+01 7.932621e+00 3 0.5000 2.822458e+00 4.461754e+00 2.260940e+00 3 0.2500 2.822599e+00 2.451565e+00 1.898167e+00 4 B(1.7e-01) 1.0000 2.451075e+00 4.645809e-02 3.012542e-01 5 B(1.7e-01) 1.0000 4.644880e-02 3.610709e-02 2.100750e-01 6 B(1.7e-01) 1.0000 3.609987e-02 4.937229e-04 3.114050e-02 7 B(1.8e-01) 1.0000 4.936242e-04 1.156794e-05 3.863626e-03 8 B(1.5e-01) 1.0000 1.156563e-05 7.281774e-08 2.923123e-04 9 B(1.5e-01) 1.0000 7.280317e-08 1.723949e-10 1.815046e-05 10 B(1.4e-01) 1.0000 1.723604e-10 2.225489e-13 6.604661e-07 11 B(1.5e-01) 1.0000 2.225044e-13 4.798220e-19 9.698051e-10 Iter Jac Lambda Ftarg Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 1.0000 2.886235e+00 5.787362e+05 1.070841e+03 1 0.1000 2.886754e+00 9.857947e+00 3.214799e+00 1 0.0500 2.886783e+00 3.719083e+00 2.396959e+00 1 0.0116 2.886805e+00 2.870160e+00 2.237867e+00 2 B(2.4e-02) 1.0000 2.869586e+00 2.627018e+03 7.080572e+01 2 0.1000 2.870103e+00 3.107845e+00 2.210215e+00 2 0.0500 2.870131e+00 2.815601e+00 2.186403e+00 3 B(7.3e-02) 1.0000 2.815038e+00 6.747287e+00 3.277316e+00 3 0.2944 2.815436e+00 1.984353e+00 1.729991e+00 4 B(1.7e-01) 1.0000 1.983957e+00 3.791830e-02 2.738028e-01 5 B(1.6e-01) 1.0000 3.791071e-02 3.152459e-02 2.000385e-01 6 B(1.7e-01) 1.0000 3.151828e-02 5.606801e-04 3.334816e-02 7 B(1.9e-01) 1.0000 5.605680e-04 1.534172e-05 4.967018e-03 8 B(1.5e-01) 1.0000 1.533865e-05 6.842815e-08 2.988884e-04 9 B(1.5e-01) 1.0000 6.841446e-08 1.950846e-10 1.962232e-05 10 B(1.4e-01) 1.0000 1.950456e-10 8.692611e-13 1.291801e-06 11 B(1.5e-01) 1.0000 8.690872e-13 2.900197e-18 2.356425e-09 nleqslv/inst/iterationreport/dspure.Rout.txt0000644000175100001440000000134512513243315021160 0ustar hornikusers Iter Jac Lambda Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 0.0982 9.425900e+00 3.110645e+00 2 B(2.0e-01) 1.0000 6.310448e-02 3.233322e-01 3 B(2.1e-01) 1.0000 1.615337e-02 1.363843e-01 4 B(1.1e-01) 1.0000 4.779562e-02 2.697882e-01 5 B(1.3e-01) 1.0000 2.907236e-04 2.336215e-02 6 B(1.4e-01) 1.0000 7.378238e-05 9.454749e-03 7 B(1.2e-01) 1.0000 2.679693e-06 1.710901e-03 8 B(1.3e-01) 1.0000 3.544248e-08 1.981990e-04 9 B(1.5e-01) 1.0000 1.621773e-12 1.360726e-06 10 B(1.5e-01) 1.0000 2.391190e-16 1.632849e-08 11 B(1.5e-01) 1.0000 2.315251e-20 1.605271e-10 nleqslv/inst/iterationreport/dspwldog.R0000644000175100001440000000124012513243175020131 0ustar hornikusers# Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 library(nleqslv) packageVersion("nleqslv") .libPaths() dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } xstart <- c(2,0.5) # \section{Report for the single (Powell) dogleg global method} nleqslv(xstart,dslnex, global="pwldog", jacobian=TRUE, control=list(trace=1,delta="cauchy")) nleqslv/inst/iterationreport/dshook.Rout0000644000175100001440000000630212513243307020326 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > library(nleqslv) > packageVersion("nleqslv") [1] '2.8' > .libPaths() [1] "/Users/berendhasselman/Documents/Programming/R/Packages/NonLinearEq.Package/nleqslv.Rcheck" [2] "/Users/berendhasselman/Library/R/3.1/library" [3] "/Library/Frameworks/R.framework/Versions/3.1/Resources/library" > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > > # \section{Report for the hook step global method} > nleqslv(xstart,dslnex, global="hook", jacobian=TRUE, control=list(trace=1,delta="cauchy")) Algorithm parameters -------------------- Method: Broyden Global strategy: More/Hebden/Lev/Marquardt (initial trust region = -1) Maximum stepsize = 1.79769e+308 Scaling: fixed ftol = 1e-08 xtol = 1e-08 btol = 0.001 cndtol = 1e-12 Iteration report ---------------- Iter Jac mu dnorm Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) H 0.1968 0.4909 0.4671 0.9343* 1.806293e-01 5.749418e-01 1 H 0.0366 0.9381 0.9343 0.4671 1.806293e-01 5.749418e-01 2 B(2.5e-02) H 0.1101 0.4745 0.4671 0.2336 1.797759e-01 5.635028e-01 3 B(1.4e-01) H 0.0264 0.2341 0.2336 0.4671 3.768809e-02 2.063234e-01 4 B(1.6e-01) N 0.0819 0.0819 0.1637 3.002274e-03 7.736213e-02 5 B(1.8e-01) N 0.0513 0.0513 0.1025 5.355533e-05 1.018879e-02 6 B(1.5e-01) N 0.0090 0.0090 0.0179 1.357039e-06 1.224357e-03 7 B(1.5e-01) N 0.0004 0.0004 0.0008 1.846111e-09 6.070166e-05 8 B(1.4e-01) N 0.0000 0.0000 0.0001 3.292896e-12 2.555851e-06 9 B(1.5e-01) N 0.0000 0.0000 0.0000 7.281583e-18 3.800552e-09 $x [1] 1 1 $fvec [1] 3.800552e-09 -3.449219e-10 $termcd [1] 1 $message [1] "Function criterion near zero" $scalex [1] 1 1 $nfcnt [1] 10 $njcnt [1] 1 $iter [1] 9 $jac [,1] [,2] [1,] 2.0124642 2.033581 [2,] 0.9991295 2.997660 > nleqslv/inst/iterationreport/00readme.txt0000644000175100001440000000165112513243771020331 0ustar hornikusers The .R files generate the trace for the iteration report section in the help/manual. They were run in OS X 10.10.3 with the following bash commands export R_LIBS=../../../nleqslv.Rcheck for k in *.R; do R CMD BATCH --no-timing $k ; done in the directory /inst/iterationreport. If they are run elsewhere you shouldn't need the export command. If these are run in a different OS or with another version of R results may be marginally different. If they are very different then I would like to be informed. The iteration reports are excerpts from the .Rout files and slightly modified with intercolumn some whitespace removed. The actual reports may be extracted from the .Rout file with this bash command for file in *.Rout ; do gawk '/ Iter /, /^[$]x/ { if($0 != "$x" ) print }' $file > $(basename $file).txt ; done Some editing will be needed before including the reports in the documentation. nleqslv/inst/iterationreport/dsdbldog.R0000644000175100001440000000122712513243175020075 0ustar hornikusers# Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 library(nleqslv) packageVersion("nleqslv") .libPaths() dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } xstart <- c(2,0.5) # \section{Report for the double dogleg global method} nleqslv(xstart,dslnex, global="dbldog", jacobian=TRUE, control=list(trace=1,delta="cauchy")) nleqslv/inst/iterationreport/dsdbldog.Rout0000644000175100001440000000667412513243307020635 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > library(nleqslv) > packageVersion("nleqslv") [1] '2.8' > .libPaths() [1] "/Users/berendhasselman/Documents/Programming/R/Packages/NonLinearEq.Package/nleqslv.Rcheck" [2] "/Users/berendhasselman/Library/R/3.1/library" [3] "/Library/Frameworks/R.framework/Versions/3.1/Resources/library" > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > > # \section{Report for the double dogleg global method} > nleqslv(xstart,dslnex, global="dbldog", jacobian=TRUE, control=list(trace=1,delta="cauchy")) Algorithm parameters -------------------- Method: Broyden Global strategy: double dogleg (initial trust region = -1) Maximum stepsize = 1.79769e+308 Scaling: fixed ftol = 1e-08 xtol = 1e-08 btol = 0.001 cndtol = 1e-12 Iteration report ---------------- Iter Jac Lambda Eta Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) C 0.9544 0.4671 0.9343* 1.699715e-01 5.421673e-01 1 W 0.0833 0.9544 0.9343 0.4671 1.699715e-01 5.421673e-01 2 B(1.1e-02) W 0.1154 0.4851 0.4671 0.4671 1.277667e-01 5.043571e-01 3 B(7.3e-02) W 0.7879 0.7289 0.4671 0.0759 5.067893e-01 7.973542e-01 3 C 0.7289 0.0759 0.1519 5.440250e-02 2.726084e-01 4 B(8.3e-02) W 0.5307 0.3271 0.1519 0.3037 3.576547e-02 2.657553e-01 5 B(1.8e-01) N 0.6674 0.2191 0.4383 6.566182e-03 8.555110e-02 6 B(1.8e-01) N 0.9801 0.0376 0.0752 4.921645e-04 3.094104e-02 7 B(1.9e-01) N 0.7981 0.0157 0.0313 4.960629e-06 2.826064e-03 8 B(1.6e-01) N 0.3942 0.0029 0.0058 1.545503e-08 1.757498e-04 9 B(1.5e-01) N 0.6536 0.0001 0.0003 2.968676e-11 5.983765e-06 10 B(1.5e-01) N 0.4730 0.0000 0.0000 4.741792e-14 2.198380e-07 11 B(1.5e-01) N 0.9787 0.0000 0.0000 6.451792e-19 8.118586e-10 $x [1] 1 1 $fvec [1] 8.118586e-10 -7.945087e-10 $termcd [1] 1 $message [1] "Function criterion near zero" $scalex [1] 1 1 $nfcnt [1] 13 $njcnt [1] 1 $iter [1] 11 $jac [,1] [,2] [1,] 2.0616260 2.103239 [2,] 0.9400911 2.899639 > nleqslv/inst/iterationreport/dspwldog.Rout.txt0000644000175100001440000000230012513243315021471 0ustar hornikusers Iter Jac Lambda Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) C 0.4671 0.9343* 1.699715e-01 5.421673e-01 1 W 0.0794 0.9343 0.4671 1.699715e-01 5.421673e-01 2 B(1.1e-02) W 0.0559 0.4671 0.4671 1.205661e-01 4.890487e-01 3 B(7.3e-02) W 0.5662 0.4671 0.0960 4.119560e-01 7.254441e-01 3 W 0.0237 0.0960 0.1921 4.426507e-02 2.139252e-01 4 B(8.8e-02) W 0.2306 0.1921 0.3842* 2.303135e-02 2.143943e-01 4 W 0.4769 0.3842 0.1921 2.303135e-02 2.143943e-01 5 B(1.9e-01) N 0.1375 0.2750 8.014508e-04 3.681498e-02 6 B(1.7e-01) N 0.0162 0.0325 1.355741e-05 5.084627e-03 7 B(1.3e-01) N 0.0070 0.0035 1.282776e-05 4.920962e-03 8 B(1.8e-01) N 0.0028 0.0056 3.678140e-08 2.643592e-04 9 B(1.9e-01) N 0.0001 0.0003 1.689182e-12 1.747622e-06 10 B(1.9e-01) N 0.0000 0.0000 9.568768e-16 4.288618e-08 11 B(1.9e-01) N 0.0000 0.0000 1.051357e-18 1.422036e-09 nleqslv/inst/iterationreport/dslnsrch.Rout0000644000175100001440000001724312513243307020665 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > library(nleqslv) > packageVersion("nleqslv") [1] '2.8' > .libPaths() [1] "/Users/berendhasselman/Documents/Programming/R/Packages/NonLinearEq.Package/nleqslv.Rcheck" [2] "/Users/berendhasselman/Library/R/3.1/library" [3] "/Library/Frameworks/R.framework/Versions/3.1/Resources/library" > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > xstart <- c(2,0.5) > > # \section{Report for linesearch methods} > cat("Linesearch qline\n----------------\n") Linesearch qline ---------------- > nleqslv(xstart,dslnex, global="qline", control=list(trace=1)) Algorithm parameters -------------------- Method: Broyden Global strategy: quadratic linesearch Maximum stepsize = 1.79769e+308 Scaling: fixed ftol = 1e-08 xtol = 1e-08 btol = 0.001 cndtol = 1e-12 Iteration report ---------------- Iter Jac Lambda Ftarg Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 1.0000 2.886235e+00 5.787362e+05 1.070841e+03 1 0.1000 2.886754e+00 9.857947e+00 3.214799e+00 1 0.0100 2.886806e+00 2.866321e+00 2.237878e+00 2 B(2.2e-02) 1.0000 2.865748e+00 4.541965e+03 9.341610e+01 2 0.1000 2.866264e+00 3.253536e+00 2.242344e+00 2 0.0298 2.866304e+00 2.805872e+00 2.200544e+00 3 B(5.5e-02) 1.0000 2.805311e+00 2.919089e+01 7.073082e+00 3 0.1000 2.805816e+00 2.437606e+00 2.027297e+00 4 B(1.0e-01) 1.0000 2.437118e+00 9.839802e-01 1.142529e+00 5 B(1.9e-01) 1.0000 9.837834e-01 7.263320e-02 3.785249e-01 6 B(2.2e-01) 1.0000 7.261868e-02 1.581364e-02 1.774419e-01 7 B(1.5e-01) 1.0000 1.581047e-02 9.328284e-03 1.213052e-01 8 B(1.7e-01) 1.0000 9.326419e-03 1.003283e-04 1.400491e-02 9 B(1.9e-01) 1.0000 1.003082e-04 3.072159e-06 2.206943e-03 10 B(1.5e-01) 1.0000 3.071544e-06 1.143217e-07 4.757203e-04 11 B(1.3e-01) 1.0000 1.142989e-07 1.144686e-09 4.783197e-05 12 B(1.2e-01) 1.0000 1.144457e-09 4.515245e-13 9.502885e-07 13 B(1.2e-01) 1.0000 4.514342e-13 1.404463e-17 5.299877e-09 $x [1] 1 1 $fvec [1] 5.299877e-09 2.378364e-11 $termcd [1] 1 $message [1] "Function criterion near zero" $scalex [1] 1 1 $nfcnt [1] 18 $njcnt [1] 1 $iter [1] 13 > # These two not in iteration report doc > cat("\nLinesearch gline\n----------------\n") Linesearch gline ---------------- > nleqslv(xstart,dslnex, global="gline", control=list(trace=1)) Algorithm parameters -------------------- Method: Broyden Global strategy: geometric linesearch (reduction = 0.5) Maximum stepsize = 1.79769e+308 Scaling: fixed ftol = 1e-08 xtol = 1e-08 btol = 0.001 cndtol = 1e-12 Iteration report ---------------- Iter Jac Lambda Ftarg Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 1.0000 2.886235e+00 5.787362e+05 1.070841e+03 1 0.5000 2.886523e+00 1.211981e+04 1.533192e+02 1 0.2500 2.886668e+00 3.346737e+02 2.454656e+01 1 0.1250 2.886740e+00 1.860606e+01 4.931671e+00 1 0.0625 2.886776e+00 4.468205e+00 2.514779e+00 1 0.0312 2.886794e+00 3.097106e+00 2.281039e+00 1 0.0156 2.886803e+00 2.888770e+00 2.240182e+00 1 0.0078 2.886808e+00 2.864341e+00 2.238756e+00 2 B(1.9e-02) 1.0000 2.863768e+00 1.026894e+04 1.410555e+02 2 0.5000 2.864054e+00 3.038612e+02 2.346774e+01 2 0.2500 2.864197e+00 1.774832e+01 4.936364e+00 2 0.1250 2.864269e+00 4.259875e+00 2.397912e+00 2 0.0625 2.864305e+00 2.987137e+00 2.220967e+00 2 0.0312 2.864323e+00 2.822740e+00 2.205520e+00 3 B(5.3e-02) 1.0000 2.822176e+00 3.640971e+01 7.932621e+00 3 0.5000 2.822458e+00 4.461754e+00 2.260940e+00 3 0.2500 2.822599e+00 2.451565e+00 1.898167e+00 4 B(1.7e-01) 1.0000 2.451075e+00 4.645809e-02 3.012542e-01 5 B(1.7e-01) 1.0000 4.644880e-02 3.610709e-02 2.100750e-01 6 B(1.7e-01) 1.0000 3.609987e-02 4.937229e-04 3.114050e-02 7 B(1.8e-01) 1.0000 4.936242e-04 1.156794e-05 3.863626e-03 8 B(1.5e-01) 1.0000 1.156563e-05 7.281774e-08 2.923123e-04 9 B(1.5e-01) 1.0000 7.280317e-08 1.723949e-10 1.815046e-05 10 B(1.4e-01) 1.0000 1.723604e-10 2.225489e-13 6.604661e-07 11 B(1.5e-01) 1.0000 2.225044e-13 4.798220e-19 9.698051e-10 $x [1] 1 1 $fvec [1] 9.698051e-10 1.382823e-10 $termcd [1] 1 $message [1] "Function criterion near zero" $scalex [1] 1 1 $nfcnt [1] 25 $njcnt [1] 1 $iter [1] 11 > cat("\nLinesearch cline\n----------------\n") Linesearch cline ---------------- > nleqslv(xstart,dslnex, global="cline", control=list(trace=1)) Algorithm parameters -------------------- Method: Broyden Global strategy: cubic linesearch Maximum stepsize = 1.79769e+308 Scaling: fixed ftol = 1e-08 xtol = 1e-08 btol = 0.001 cndtol = 1e-12 Iteration report ---------------- Iter Jac Lambda Ftarg Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 1.0000 2.886235e+00 5.787362e+05 1.070841e+03 1 0.1000 2.886754e+00 9.857947e+00 3.214799e+00 1 0.0500 2.886783e+00 3.719083e+00 2.396959e+00 1 0.0116 2.886805e+00 2.870160e+00 2.237867e+00 2 B(2.4e-02) 1.0000 2.869586e+00 2.627018e+03 7.080572e+01 2 0.1000 2.870103e+00 3.107845e+00 2.210215e+00 2 0.0500 2.870131e+00 2.815601e+00 2.186403e+00 3 B(7.3e-02) 1.0000 2.815038e+00 6.747287e+00 3.277316e+00 3 0.2944 2.815436e+00 1.984353e+00 1.729991e+00 4 B(1.7e-01) 1.0000 1.983957e+00 3.791830e-02 2.738028e-01 5 B(1.6e-01) 1.0000 3.791071e-02 3.152459e-02 2.000385e-01 6 B(1.7e-01) 1.0000 3.151828e-02 5.606801e-04 3.334816e-02 7 B(1.9e-01) 1.0000 5.605680e-04 1.534172e-05 4.967018e-03 8 B(1.5e-01) 1.0000 1.533865e-05 6.842815e-08 2.988884e-04 9 B(1.5e-01) 1.0000 6.841446e-08 1.950846e-10 1.962232e-05 10 B(1.4e-01) 1.0000 1.950456e-10 8.692611e-13 1.291801e-06 11 B(1.5e-01) 1.0000 8.690872e-13 2.900197e-18 2.356425e-09 $x [1] 1 1 $fvec [1] 2.356425e-09 -4.976490e-10 $termcd [1] 1 $message [1] "Function criterion near zero" $scalex [1] 1 1 $nfcnt [1] 17 $njcnt [1] 1 $iter [1] 11 > nleqslv/inst/iterationreport/dshook.Rout.txt0000644000175100001440000000177412513243315021153 0ustar hornikusers Iter Jac mu dnorm Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) H 0.1968 0.4909 0.4671 0.9343* 1.806293e-01 5.749418e-01 1 H 0.0366 0.9381 0.9343 0.4671 1.806293e-01 5.749418e-01 2 B(2.5e-02) H 0.1101 0.4745 0.4671 0.2336 1.797759e-01 5.635028e-01 3 B(1.4e-01) H 0.0264 0.2341 0.2336 0.4671 3.768809e-02 2.063234e-01 4 B(1.6e-01) N 0.0819 0.0819 0.1637 3.002274e-03 7.736213e-02 5 B(1.8e-01) N 0.0513 0.0513 0.1025 5.355533e-05 1.018879e-02 6 B(1.5e-01) N 0.0090 0.0090 0.0179 1.357039e-06 1.224357e-03 7 B(1.5e-01) N 0.0004 0.0004 0.0008 1.846111e-09 6.070166e-05 8 B(1.4e-01) N 0.0000 0.0000 0.0001 3.292896e-12 2.555851e-06 9 B(1.5e-01) N 0.0000 0.0000 0.0000 7.281583e-18 3.800552e-09 nleqslv/inst/iterationreport/dspure.R0000644000175100001440000000123112513243175017610 0ustar hornikusers# Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 library(nleqslv) packageVersion("nleqslv") .libPaths() dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } xstart <- c(2,0.5) # \section{Report for the single (Powell) dogleg global method} nleqslv(xstart,dslnex, global="none", jacobian=TRUE, control=list(trace=1,stepmax=1)) nleqslv/inst/iterationreport/dspure.Rout0000644000175100001440000000557012513243307020347 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > library(nleqslv) > packageVersion("nleqslv") [1] '2.8' > .libPaths() [1] "/Users/berendhasselman/Documents/Programming/R/Packages/NonLinearEq.Package/nleqslv.Rcheck" [2] "/Users/berendhasselman/Library/R/3.1/library" [3] "/Library/Frameworks/R.framework/Versions/3.1/Resources/library" > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > > # \section{Report for the single (Powell) dogleg global method} > nleqslv(xstart,dslnex, global="none", jacobian=TRUE, control=list(trace=1,stepmax=1)) Algorithm parameters -------------------- Method: Broyden Global strategy: none Maximum stepsize = 1 Scaling: fixed ftol = 1e-08 xtol = 1e-08 btol = 0.001 cndtol = 1e-12 Iteration report ---------------- Iter Jac Lambda Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 0.0982 9.425900e+00 3.110645e+00 2 B(2.0e-01) 1.0000 6.310448e-02 3.233322e-01 3 B(2.1e-01) 1.0000 1.615337e-02 1.363843e-01 4 B(1.1e-01) 1.0000 4.779562e-02 2.697882e-01 5 B(1.3e-01) 1.0000 2.907236e-04 2.336215e-02 6 B(1.4e-01) 1.0000 7.378238e-05 9.454749e-03 7 B(1.2e-01) 1.0000 2.679693e-06 1.710901e-03 8 B(1.3e-01) 1.0000 3.544248e-08 1.981990e-04 9 B(1.5e-01) 1.0000 1.621773e-12 1.360726e-06 10 B(1.5e-01) 1.0000 2.391190e-16 1.632849e-08 11 B(1.5e-01) 1.0000 2.315251e-20 1.605271e-10 $x [1] 1 1 $fvec [1] -1.433040e-10 -1.605271e-10 $termcd [1] 1 $message [1] "Function criterion near zero" $scalex [1] 1 1 $nfcnt [1] 11 $njcnt [1] 1 $iter [1] 11 $jac [,1] [,2] [1,] 1.6062610 2.238841 [2,] 0.5589314 3.267552 > nleqslv/inst/iterationreport/dsdbldog.Rout.txt0000644000175100001440000000237312513243315021442 0ustar hornikusers Iter Jac Lambda Eta Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) C 0.9544 0.4671 0.9343* 1.699715e-01 5.421673e-01 1 W 0.0833 0.9544 0.9343 0.4671 1.699715e-01 5.421673e-01 2 B(1.1e-02) W 0.1154 0.4851 0.4671 0.4671 1.277667e-01 5.043571e-01 3 B(7.3e-02) W 0.7879 0.7289 0.4671 0.0759 5.067893e-01 7.973542e-01 3 C 0.7289 0.0759 0.1519 5.440250e-02 2.726084e-01 4 B(8.3e-02) W 0.5307 0.3271 0.1519 0.3037 3.576547e-02 2.657553e-01 5 B(1.8e-01) N 0.6674 0.2191 0.4383 6.566182e-03 8.555110e-02 6 B(1.8e-01) N 0.9801 0.0376 0.0752 4.921645e-04 3.094104e-02 7 B(1.9e-01) N 0.7981 0.0157 0.0313 4.960629e-06 2.826064e-03 8 B(1.6e-01) N 0.3942 0.0029 0.0058 1.545503e-08 1.757498e-04 9 B(1.5e-01) N 0.6536 0.0001 0.0003 2.968676e-11 5.983765e-06 10 B(1.5e-01) N 0.4730 0.0000 0.0000 4.741792e-14 2.198380e-07 11 B(1.5e-01) N 0.9787 0.0000 0.0000 6.451792e-19 8.118586e-10 nleqslv/inst/iterationreport/dslnsrch.R0000644000175100001440000000133612513243303020125 0ustar hornikusers# Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 library(nleqslv) packageVersion("nleqslv") .libPaths() dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } xstart <- c(2,0.5) # \section{Report for linesearch methods} cat("Linesearch qline\n----------------\n") nleqslv(xstart,dslnex, global="qline", control=list(trace=1)) # These two not in iteration report doc cat("\nLinesearch gline\n----------------\n") nleqslv(xstart,dslnex, global="gline", control=list(trace=1)) cat("\nLinesearch cline\n----------------\n") nleqslv(xstart,dslnex, global="cline", control=list(trace=1)) nleqslv/inst/iterationreport/dspwldog.Rout0000644000175100001440000000661012513243307020664 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > library(nleqslv) > packageVersion("nleqslv") [1] '2.8' > .libPaths() [1] "/Users/berendhasselman/Documents/Programming/R/Packages/NonLinearEq.Package/nleqslv.Rcheck" [2] "/Users/berendhasselman/Library/R/3.1/library" [3] "/Library/Frameworks/R.framework/Versions/3.1/Resources/library" > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > > # \section{Report for the single (Powell) dogleg global method} > nleqslv(xstart,dslnex, global="pwldog", jacobian=TRUE, control=list(trace=1,delta="cauchy")) Algorithm parameters -------------------- Method: Broyden Global strategy: single dogleg (initial trust region = -1) Maximum stepsize = 1.79769e+308 Scaling: fixed ftol = 1e-08 xtol = 1e-08 btol = 0.001 cndtol = 1e-12 Iteration report ---------------- Iter Jac Lambda Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) C 0.4671 0.9343* 1.699715e-01 5.421673e-01 1 W 0.0794 0.9343 0.4671 1.699715e-01 5.421673e-01 2 B(1.1e-02) W 0.0559 0.4671 0.4671 1.205661e-01 4.890487e-01 3 B(7.3e-02) W 0.5662 0.4671 0.0960 4.119560e-01 7.254441e-01 3 W 0.0237 0.0960 0.1921 4.426507e-02 2.139252e-01 4 B(8.8e-02) W 0.2306 0.1921 0.3842* 2.303135e-02 2.143943e-01 4 W 0.4769 0.3842 0.1921 2.303135e-02 2.143943e-01 5 B(1.9e-01) N 0.1375 0.2750 8.014508e-04 3.681498e-02 6 B(1.7e-01) N 0.0162 0.0325 1.355741e-05 5.084627e-03 7 B(1.3e-01) N 0.0070 0.0035 1.282776e-05 4.920962e-03 8 B(1.8e-01) N 0.0028 0.0056 3.678140e-08 2.643592e-04 9 B(1.9e-01) N 0.0001 0.0003 1.689182e-12 1.747622e-06 10 B(1.9e-01) N 0.0000 0.0000 9.568768e-16 4.288618e-08 11 B(1.9e-01) N 0.0000 0.0000 1.051357e-18 1.422036e-09 $x [1] 1 1 $fvec [1] 2.837748e-10 1.422036e-09 $termcd [1] 1 $message [1] "Function criterion near zero" $scalex [1] 1 1 $nfcnt [1] 14 $njcnt [1] 1 $iter [1] 11 $jac [,1] [,2] [1,] 1.9128580 1.932369 [2,] 0.5633352 2.661106 > nleqslv/tests/0000755000175100001440000000000012751667623013135 5ustar hornikusersnleqslv/tests/trig.R0000644000175100001440000000120312103676167014213 0ustar hornikusers library("nleqslv") # Trigonometric function trig <- function(x) { n <- length(x) y <- cos(x) s <- sum(y) y <- n - s + c(1:n) * (1-y) - sin(x) y } trigjac <- function(x) { n <- length(x) J <- matrix(numeric(n*n),n,n) for (p in 1:n) { J[,p] <- sin(x[p]) J[p,p] <- (p+1) * sin(x[p]) - cos(x[p]) } J } do.print.xf <- FALSE print.result <- function(z) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } n <- 10 xstart <- rep(1,n)/n fstart <- trig(xstart) znlm <- nleqslv(xstart, trig, global="dbldog", control=list(trace=0)) print.result(znlm) nleqslv/tests/singular1.R0000644000175100001440000000145112505767436015166 0ustar hornikusers library(nleqslv) # Brown almost linear function brown <- function(x) { n <- length(x) y <- numeric(n) y[1:(n-1)] <- x[1:(n-1)] + sum(x[1:n]) - (n + 1) y[n] <- prod(x[1:n]) - 1.0 y } brownjac <- function(x) { n <- length(x) J <- matrix(1,nrow=n,ncol=n) diag(J) <- 2 xprod <- prod(x) J[n,] <- xprod/x # exact J } print.result <- function(z, do.print.xf=FALSE) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } for( m in c("Newton","Broyden") ) { for( n in c(50,100) ) { xstart <- rep(1,n)/2 z <- nleqslv(xstart, brown, brownjac, method="Newton", control=list(trace=0,ftol=1e-10,delta="cauchy",allowSingular=TRUE)) print.result(z) } } nleqslv/tests/tscalargrad.Rout.save0000644000175100001440000000275512751667720017243 0ustar hornikusers R version 3.3.1 (2016-06-21) -- "Bug in Your Hair" Copyright (C) 2016 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # http://r.789695.n4.nabble.com/newton-method-td2306111.html#a2306111 > # R-help, 29-07-2010: newton.method > > library(nleqslv) > > f <- function(x) 2.5*exp(-0.5*(2*0.045 - x)) + 2.5*exp(-0.045) + 2.5*exp(-1.5*x) - 100 > > g1 <- function(x) 0.5*2.5*exp(-0.5*(2*0.045 - x)) - 1.5*2.5*exp(-1.5*x) > g2 <- function(x) matrix(0.5*2.5*exp(-0.5*(2*0.045 - x)) - 1.5*2.5*exp(-1.5*x), nrow=1,ncol=1) > > xu.1 <- uniroot(f,c(-3,0), tol=1e-8)$root > xu.2 <- uniroot(f,c( 6,8), tol=1e-8)$root > > xg1.1 <- nleqslv(-2,f,g1)$x > xg2.1 <- nleqslv(-2,f,g2)$x > > xg1.2 <- nleqslv(8,f,g1)$x > xg2.2 <- nleqslv(8,f,g2)$x > > all.equal(xg1.1, xu.1) [1] TRUE > all.equal(xg1.2, xu.2) [1] TRUE > all.equal(xg1.2, xg2.2) [1] TRUE > > all.equal(xg2.1, xu.1) [1] TRUE > all.equal(xg2.2, xu.2) [1] TRUE > all.equal(xg1.2, xg2.2) [1] TRUE > nleqslv/tests/dslnexCN.Rout0000644000175100001440000000411512360445734015520 0ustar hornikusers R version 3.1.1 (2014-07-10) -- "Sock it to Me" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("nleqslv") > > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > > xstart <- c(2,0.5) > fstart <- dslnex(xstart) > xstart [1] 2.0 0.5 > fstart [1] 2.2500000 0.8432818 > > do.print.xf <- TRUE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > sink("dslnexCN-num.txt") > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta, trace=1)) + print.result(znlq) + } + } > sink() > > sink("dslnexCN-char.txt") > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c("cauchy", "newton") ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta,trace=1)) + print.result(znlq) + } + } > sink() > > z1 <- readLines(con="dslnexCN-num.txt") > z2 <- readLines(con="dslnexCN-char.txt") > > all.equal(z1,z2) [1] TRUE > > proc.time() user system elapsed 0.255 0.051 0.427 nleqslv/tests/control-try.Rout.save0000644000175100001440000000247212624143663017236 0ustar hornikusers R version 3.2.2 Patched (2015-10-19 r69552) -- "Fire Safety" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > # Dennis Schnabel example 6.5.1 page 149 > f <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > # check error handling in control argument > try(nleqslv(f,control=list(1e-3))) Error in nleqslv(f, control = list(0.001)) : 'control' argument must be a named list > try(nleqslv(f,control=list(f=1e-3))) Error in nleqslv(f, control = list(f = 0.001)) : unknown names in control: 'f' > try(nleqslv(f,control=list(f=1e-7,b=1e-3))) Error in nleqslv(f, control = list(f = 1e-07, b = 0.001)) : unknown names in control: 'f', 'b' > nleqslv/tests/brdtri.Rout.save0000644000175100001440000000504512634510272016222 0ustar hornikusers R version 3.2.3 (2015-12-10) -- "Wooden Christmas-Tree" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Broyden tridiagonal > > library("nleqslv") > > brdtri <- function(x) { + n <- length(x) + y <- numeric(n) + + y[1] <- (3-2*x[1])*x[1] - 2*x[2] + 1 + y[n] <- (3-2*x[n])*x[n] - x[n-1] + 1 + + k <- 2:(n-1) + y[k] <- (3-2*x[k])*x[k] - x[k-1] - 2 * x[k+1] + 1 + + y + } > > n <- 100 > xstart <- -rep(1,n) > ztol <- 1000*.Machine$double.eps > > z1 <- nleqslv(xstart,brdtri, method="Newton") > z2 <- nleqslv(xstart,brdtri, method="Newton", control=list(dsub=1,dsuper=1)) > > cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") z1 termcd= 1 jcnt,fcnt= 4 4 > cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z2 termcd= 1 jcnt,fcnt= 4 4 > z1$message [1] "Function criterion near zero" > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z1$x) [1] TRUE > all.equal(z2$x,z1$x, tolerance=ztol) [1] TRUE > > z1 <- nleqslv(xstart,brdtri, method="Newton") > z2 <- nleqslv(xstart,brdtri, method="Newton", control=list(dsub=1,dsuper=1)) > > cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") z1 termcd= 1 jcnt,fcnt= 4 4 > cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z2 termcd= 1 jcnt,fcnt= 4 4 > z1$message [1] "Function criterion near zero" > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z1$x, tolerance=ztol) [1] TRUE > > z3 <- nleqslv(xstart,brdtri, method="Broyden") > z4 <- nleqslv(xstart,brdtri, method="Broyden", control=list(dsub=1,dsuper=1)) > > cat("z3 termcd=",z1$termcd, "jcnt,fcnt=",z3$njcnt,z3$nfcnt,"\n") z3 termcd= 1 jcnt,fcnt= 1 10 > cat("z4 termcd=",z2$termcd, "jcnt,fcnt=",z4$njcnt,z4$nfcnt,"\n") z4 termcd= 1 jcnt,fcnt= 1 10 > z3$message [1] "x-values within tolerance 'xtol'" > z4$message [1] "x-values within tolerance 'xtol'" > all.equal(z3$x,z1$x) [1] TRUE > all.equal(z4$x,z1$x) [1] TRUE > all.equal(z4$x,z3$x, tolerance=ztol) [1] TRUE > > proc.time() user system elapsed 0.178 0.024 0.193 nleqslv/tests/singular1.Rout.save0000644000175100001440000000333612505767436016657 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > # Brown almost linear function > > brown <- function(x) { + n <- length(x) + y <- numeric(n) + + y[1:(n-1)] <- x[1:(n-1)] + sum(x[1:n]) - (n + 1) + y[n] <- prod(x[1:n]) - 1.0 + + y + } > > brownjac <- function(x) { + n <- length(x) + J <- matrix(1,nrow=n,ncol=n) + diag(J) <- 2 + xprod <- prod(x) + J[n,] <- xprod/x # exact + J + } > > print.result <- function(z, do.print.xf=FALSE) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > for( m in c("Newton","Broyden") ) { + for( n in c(50,100) ) { + xstart <- rep(1,n)/2 + z <- nleqslv(xstart, brown, brownjac, method="Newton", + control=list(trace=0,ftol=1e-10,delta="cauchy",allowSingular=TRUE)) + print.result(z) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > nleqslv/tests/brdtrijac.Rout.save0000644000175100001440000000426512301444213016673 0ustar hornikusers R version 3.0.2 Patched (2014-01-27 r64897) -- "Frisbee Sailing" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Broyden banded function > > library(nleqslv) > > brdtri <- function(x) { + n <- length(x) + y <- numeric(n) + + # y[1] <- (3-2*x[1])*x[1] - 2*x[2] + 1 + # y[n] <- (3-2*x[n])*x[n] - x[n-1] + 1 + # + # k <- 2:(n-1) + # y[k] <- (3-2*x[k])*x[k] - x[k-1] - 2 * x[k+1] + 1 + # + y <- (3-2*x)*x - c(0,x[-n]) - 2*c(x[-1],0) + 1 + y + } > > brdtrijac <- function(x) { + n <- length(x) + J <- diag(3-4*x,n,n) + J[row(J)==col(J)+1] <- -1 + J[row(J)==col(J)-1] <- -2 + J + } > > options(echo=TRUE) > > n <- 10 > xstart <- -rep(1,n) > fstart <- brdtri(xstart) > > z0 <- nleqslv(xstart,brdtri, method="Newton", global="dbldog") > z0$message [1] "Function criterion near zero" > > z1 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0)) > z1$message [1] "Function criterion near zero" > all.equal(z1$x,z0$x) [1] TRUE > > z2 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,chkjac=TRUE)) > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z0$x) [1] TRUE > > z3 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,dsub=1,dsuper=1)) > z3$message [1] "Function criterion near zero" > all.equal(z2$x,z0$x) [1] TRUE > > z4 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,dsub=1,dsuper=1,chkjac=TRUE)) > z4$message [1] "Function criterion near zero" > all.equal(z2$x,z0$x) [1] TRUE > > proc.time() user system elapsed 0.309 0.050 0.346 nleqslv/tests/singular2.Rout.save0000644000175100001440000000445112507302267016644 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # http://stackoverflow.com/questions/29134996/solving-nonlinear-equation-in-r > > # wants to know if system has closed form solution > # I want to see how nleqslv behaves > > set.seed(29) > > library(nleqslv) > > print.result <- function(z, do.print.xf=FALSE) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > f <- function(X, a, b, c1, c2, c3) { + Y <- numeric(3) + x <- X[1] + y <- X[2] + z <- X[3] + Y[1] <- x + y - x*y - c1 + Y[2] <- x + z - x*z - c2 + Y[3] <- a*y + b*z - c3 + return(Y) + } > > Jac <- function(X, a, b, c1, c2, c3) { + J <- matrix(0,nrow=3,ncol=3) + x <- X[1] + y <- X[2] + z <- X[3] + + J[1,1] <- 1-y + J[2,1] <- 1-z + J[3,1] <- 0 + J[1,2] <- 1-x + J[2,2] <- 0 + J[3,2] <- a + J[1,3] <- 0 + J[2,3] <- 1-x + J[3,3] <- b + J + } > > a <- 1 > b <- 1 > c1 <- 2 > c2 <- 3 > c3 <- 4 > > # exact solution > x <- (a*c1+b*c2-c3)/(a+b-c3) > y <- (b*c1-b*c2-c1*c3+c3)/(-a*c1+a-b*c2+b) > z <- (a*(c1-c2)+(c2-1)*c3)/(a*(c1-1)+b*(c2-1)) > xsol <- c(x,y,z) > > X.start <- c(1,2,3) > z1 <- nleqslv(X.start,f,Jac,a=a,b=b,c1=c1,c2=c2,c3=c3, + method="Newton",control=list(trace=0,allowSingular=TRUE)) > > z2 <- nleqslv(X.start,f,Jac,a=a,b=b,c1=c1,c2=c2,c3=c3, + method="Broyden",control=list(trace=0,allowSingular=TRUE)) > > all.equal(z1$x,xsol) [1] TRUE > all.equal(z2$x,xsol) [1] TRUE > print.result(z1) [1] "Function criterion near zero" [1] TRUE > print.result(z2) [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.158 0.020 0.170 nleqslv/tests/dslnexHook.R0000644000175100001440000000326212371206772015371 0ustar hornikusers library(nleqslv) # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } do.print.xf <- FALSE do.trace <- 0 print.result <- function(z) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } xcmp.result <- function(z1,z2) all(abs(z1$x-z2$x) <= 1e-8) xstart <- c(2,0.5) hnlq1 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="cauchy", trace=do.trace)) hnlq2 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="newton", trace=do.trace)) print.result(hnlq1) print.result(hnlq2) xcmp.result(hnlq1,hnlq2) dnlq1 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="cauchy", trace=do.trace)) dnlq2 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="newton", trace=do.trace)) print.result(dnlq1) print.result(dnlq2) xcmp.result(dnlq1,dnlq2) xcmp.result(hnlq1,dnlq1) xstart <- c(1.1,1.1) hnlq1 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="cauchy", trace=do.trace)) hnlq2 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="newton", trace=do.trace)) print.result(hnlq1) print.result(hnlq2) xcmp.result(hnlq1,hnlq2) dnlq1 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="cauchy", trace=do.trace)) dnlq2 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="newton", trace=do.trace)) print.result(dnlq1) print.result(dnlq2) xcmp.result(dnlq1,dnlq2) xcmp.result(hnlq1,dnlq1) nleqslv/tests/brdbanded.R0000644000175100001440000000277212250620070015150 0ustar hornikusers# Broyden banded library("nleqslv") brdban <- function(x,ml=5,mu=1) { n <- length(x) y <- numeric(n) for( k in 1:n ) { k1 <- max(1, k - ml) k2 <- min(n, k + mu) temp <- 0.0 for(j in k1:k2) { if ( j != k ) { temp <- temp + x[j] * (1.0 + x[j]) } } y[k] <- x[k] * (2.0 + 5.0 * x[k]**2) + 1.0 - temp } y } n <- 10 xstart <- -rep(1,n) ztol <- 1000*.Machine$double.eps z1 <- nleqslv(xstart,brdban, method="Newton") z2 <- nleqslv(xstart,brdban, method="Newton", control=list(dsub=5,dsuper=1)) cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z1$message z2$message all.equal(z2$x,z1$x) all.equal(z2$x,z1$x, tolerance=ztol) z1 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Newton") z2 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Newton", control=list(dsub=2,dsuper=2)) cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z1$message z2$message all.equal(z2$x,z1$x, tolerance=ztol) z3 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Broyden") z4 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Broyden", control=list(dsub=2,dsuper=2)) cat("z3 termcd=",z1$termcd, "jcnt,fcnt=",z3$njcnt,z3$nfcnt,"\n") cat("z4 termcd=",z2$termcd, "jcnt,fcnt=",z4$njcnt,z4$nfcnt,"\n") z3$message z4$message all.equal(z3$x,z1$x) all.equal(z4$x,z1$x) all.equal(z4$x,z3$x, tolerance=ztol) nleqslv/tests/xnames.R0000644000175100001440000000062112076331353014536 0ustar hornikusers library(nleqslv) f <- function(x) { y <-numeric(length(x)) y[1] <- x[1]^2 + x[2]^3 y[2] <- x[1] + 2*x[2] + 3 y } # test named x-values xstart <- c(a=1.0, b=0.5) xstart z <- nleqslv(xstart,f, control=list(trace=0)) all(names(z$x) == names(xstart)) # test named x-values xstart <- c(u=1.0, 0.5) xstart z <- nleqslv(xstart,f, control=list(trace=0)) all(names(z$x) == names(xstart)) nleqslv/tests/dslnexHook.Rout.save0000644000175100001440000000571512371105450017052 0ustar hornikusers R version 3.1.1 (2014-07-10) -- "Sock it to Me" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > > do.print.xf <- FALSE > do.trace <- 0 > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > xcmp.result <- function(z1,z2) all(abs(z1$x-z2$x) <= 1e-8) > > xstart <- c(2,0.5) > hnlq1 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="cauchy", trace=do.trace)) > hnlq2 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="newton", trace=do.trace)) > print.result(hnlq1) [1] "Function criterion near zero" [1] TRUE > print.result(hnlq2) [1] "Function criterion near zero" [1] TRUE > xcmp.result(hnlq1,hnlq2) [1] TRUE > > dnlq1 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="cauchy", trace=do.trace)) > dnlq2 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="newton", trace=do.trace)) > print.result(dnlq1) [1] "Function criterion near zero" [1] TRUE > print.result(dnlq2) [1] "Function criterion near zero" [1] TRUE > xcmp.result(dnlq1,dnlq2) [1] TRUE > xcmp.result(hnlq1,dnlq1) [1] TRUE > > xstart <- c(1.1,1.1) > hnlq1 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="cauchy", trace=do.trace)) > hnlq2 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="newton", trace=do.trace)) > print.result(hnlq1) [1] "Function criterion near zero" [1] TRUE > print.result(hnlq2) [1] "Function criterion near zero" [1] TRUE > xcmp.result(hnlq1,hnlq2) [1] TRUE > > dnlq1 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="cauchy", trace=do.trace)) > dnlq2 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="newton", trace=do.trace)) > print.result(dnlq1) [1] "Function criterion near zero" [1] TRUE > print.result(dnlq2) [1] "Function criterion near zero" [1] TRUE > xcmp.result(dnlq1,dnlq2) [1] TRUE > xcmp.result(hnlq1,dnlq1) [1] TRUE > > proc.time() user system elapsed 0.319 0.048 0.353 nleqslv/tests/dslnexscaled.R0000644000175100001440000000274312371206772015727 0ustar hornikusers# Dennis Schnabel example library("nleqslv") dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } xstart <- c(2,0.5) fstart <- dslnex(xstart) xstart fstart # a solution is c(1,1) do.print.xf <- FALSE print.result <- function(z) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } # Use our fixed scaling znlq <- nleqslv(xstart, dslnex, jacdsln, global="dbldog", control=list(btol=.01,delta=-1.0,chkjac=TRUE,scalex=c(2,3))) if(znlq$termcd == -10) stop("Internal error in check analytical jacobian") # Broyden analytical jacobian for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, jacdsln, global=z, control=list(btol=.01,delta=delta,chkjac=TRUE,scalex=c(2,3))) print.result(znlq) } } # Newton analytical jacobian for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z, control=list(btol=.01,delta=delta,chkjac=TRUE,scalex=c(2,3))) print.result(znlq) } } nleqslv/tests/xnames.Rout0000644000175100001440000000243112076331367015274 0ustar hornikusers R version 2.15.2 Patched (2013-01-16 r61667) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > f <- function(x) { + y <-numeric(length(x)) + y[1] <- x[1]^2 + x[2]^3 + y[2] <- x[1] + 2*x[2] + 3 + y + } > > # test named x-values > xstart <- c(a=1.0, b=0.5) > xstart a b 1.0 0.5 > > z <- nleqslv(xstart,f, control=list(trace=0)) > all(names(z$x) == names(xstart)) [1] TRUE > > # test named x-values > xstart <- c(u=1.0, 0.5) > xstart u 1.0 0.5 > > z <- nleqslv(xstart,f, control=list(trace=0)) > all(names(z$x) == names(xstart)) [1] TRUE > > proc.time() user system elapsed 0.325 0.043 0.363 nleqslv/tests/xcutlip1p2.Rout.save0000644000175100001440000000442012572255121016743 0ustar hornikusers R version 3.2.2 Patched (2015-08-25 r69180) -- "Fire Safety" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Steady-State solution for reaction rate equations > # Shacham homotopy method (discrete changing of one or more parameters) > # M. Shacham: Numerical Solution of Constrained Non-linear algebriac equations > # International Journal for Numerical Methods in Engineering, 1986, pp.1455--1481. > > # solution should always be > 0 > > library(nleqslv) > > RNGkind(kind="Wichmann-Hill") > set.seed(123) > > # Problem 2, page 1463/1464 > > cutlip <- function(x) { + # paper has wrong order of parameters + # use the Fortran program to get the correct values + + # parameter set 2 + k1 <- 17.721 + k2 <- 3.483 + k3 <- 505.051 + kr1<- 0.118 + kr2<- 0.033 + + r <- numeric(6) + + r[1] = 1 - x[1] - k1*x[1]*x[6] + kr1 * x[4] + r[2] = 1 - x[2] - k2*x[2]*x[6] + kr2 * x[5] + r[3] = -x[3] + 2*k3*x[4]*x[5] + r[4] = k1*x[1]*x[6] - kr1*x[4] - k3*x[4]*x[5] + r[5] = 1.5*(k2*x[2]*x[6] - kr2*x[5]) - k3*x[4]*x[5] + r[6] = 1 - x[4] - x[5] - x[6] + + r + } > > > Nrep <- 50 > xstart <- matrix(0,nrow=Nrep, ncol=6) > xstart[,1] <- runif(Nrep,min=0,max=2) > xstart[,2] <- runif(Nrep,min=0,max=1) > xstart[,3] <- runif(Nrep,min=0,max=2) > xstart[,4] <- runif(Nrep,min=0,max=1) > xstart[,5] <- runif(Nrep,min=0,max=1) > xstart[,6] <- runif(Nrep,min=0,max=1) > > ans <- searchZeros(xstart,cutlip, method="Broyden",global="dbldog") > nrow(ans$x)==4 [1] TRUE > all(ans$xfnorm <= 1e-10) [1] TRUE > > zans <- searchZeros(ans$xstart,cutlip, method="Broyden",global="dbldog") > length(zans$idxcvg)==4 [1] TRUE > all(ans$xfnorm == zans$xfnorm) [1] TRUE > > proc.time() user system elapsed 0.228 0.020 0.238 nleqslv/tests/chquad.Rout.save0000644000175100001440000000374512103676260016207 0ustar hornikusers R version 2.15.2 Patched (2013-01-21 r61728) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > # Chebyquad functions (no solution for n=8) > > library("nleqslv") > > chebyquad <- function(x) { + n <- length(x) + y <- numeric(n) + + for(j in 1:n) { + t1 <- 1.0 + t2 <- 2.0*x[j] - 1.0 + tmp <- 2.0*t2 + + for(i in 1:n) { + y[i] <- y[i] + t2 + t3 <- tmp * t2 - t1 + t1 <- t2 + t2 <- t3 + } + } + + y = y / n + + for(i in 1:n) { + if ( i%%2 == 0 ) { + y[i] = y[i] + 1.0 / (i * i - 1) + } + } + + y + } > > chebyinit <- function(n) { + x <- (1:n) / (n + 1) + } > > for (n in c(1:7,9)) { # exclude n=8 since there is no solution + xstart <- chebyinit(n) + fstart <- chebyquad(xstart) + + zz <- nleqslv(xstart, chebyquad, global="dbldog", + control=list(ftol=1e-8,xtol=1e-8,trace=0,btol=.01,delta=-2)) + print(all(abs(zz$fvec)<=1e-8)) + } [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE > > for (n in c(1:7,9)) { # exclude n=8 since there is no solution + xstart <- chebyinit(n) + fstart <- chebyquad(xstart) + + zz <- nleqslv(xstart, chebyquad, global="dbldog", method="Newton", + control=list(ftol=1e-8,xtol=1e-8,trace=0,btol=.01,delta=-2)) + print(all(abs(zz$fvec)<=1e-8)) + } [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE > > proc.time() user system elapsed 0.374 0.046 0.401 nleqslv/tests/dslnexjacout.R0000644000175100001440000000237112371206772015756 0ustar hornikusers# Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 library(nleqslv) dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } do.print.xf <- FALSE do.trace <- 0 print.result <- function(z) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } xstart <- c(2,.5) z <- nleqslv(xstart,dslnex, jacobian=TRUE, control=list(trace=do.trace)) print.result(z) all.equal(z$jac,jacdsln(z$x), tolerance=0.05) z <- nleqslv(xstart,dslnex,jacdsln, jacobian=TRUE, control=list(trace=do.trace)) print.result(z) all.equal(z$jac,jacdsln(z$x), tolerance=0.05) z <- nleqslv(xstart,dslnex, method="Newton", jacobian=TRUE, control=list(trace=do.trace)) print.result(z) all.equal(z$jac,jacdsln(z$x), tolerance=10^3*.Machine$double.eps^0.5) z <- nleqslv(xstart,dslnex, jacdsln, method="Newton", jacobian=TRUE, control=list(trace=do.trace)) print.result(z) identical(z$jac,jacdsln(z$x)) nleqslv/tests/brdbanded.Rout.save0000644000175100001440000000534712250620160016636 0ustar hornikusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Broyden banded > > library("nleqslv") > > brdban <- function(x,ml=5,mu=1) { + n <- length(x) + y <- numeric(n) + + for( k in 1:n ) { + + k1 <- max(1, k - ml) + k2 <- min(n, k + mu) + + temp <- 0.0 + for(j in k1:k2) { + if ( j != k ) { + temp <- temp + x[j] * (1.0 + x[j]) + } + } + + y[k] <- x[k] * (2.0 + 5.0 * x[k]**2) + 1.0 - temp + + } + y + } > > n <- 10 > xstart <- -rep(1,n) > ztol <- 1000*.Machine$double.eps > > z1 <- nleqslv(xstart,brdban, method="Newton") > z2 <- nleqslv(xstart,brdban, method="Newton", control=list(dsub=5,dsuper=1)) > > cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") z1 termcd= 1 jcnt,fcnt= 5 5 > cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z2 termcd= 1 jcnt,fcnt= 5 5 > z1$message [1] "Function criterion near zero" > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z1$x) [1] TRUE > all.equal(z2$x,z1$x, tolerance=ztol) [1] TRUE > > z1 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Newton") > z2 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Newton", control=list(dsub=2,dsuper=2)) > > cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") z1 termcd= 1 jcnt,fcnt= 5 5 > cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z2 termcd= 1 jcnt,fcnt= 5 5 > z1$message [1] "Function criterion near zero" > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z1$x, tolerance=ztol) [1] TRUE > > z3 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Broyden") > z4 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Broyden", control=list(dsub=2,dsuper=2)) > > cat("z3 termcd=",z1$termcd, "jcnt,fcnt=",z3$njcnt,z3$nfcnt,"\n") z3 termcd= 1 jcnt,fcnt= 1 20 > cat("z4 termcd=",z2$termcd, "jcnt,fcnt=",z4$njcnt,z4$nfcnt,"\n") z4 termcd= 1 jcnt,fcnt= 1 20 > z3$message [1] "Function criterion near zero" > z4$message [1] "Function criterion near zero" > all.equal(z3$x,z1$x) [1] TRUE > all.equal(z4$x,z1$x) [1] TRUE > all.equal(z4$x,z3$x, tolerance=ztol) [1] TRUE > > proc.time() user system elapsed 0.377 0.051 0.415 nleqslv/tests/brdtri.Rout0000644000175100001440000000504512634510272015265 0ustar hornikusers R version 3.2.3 (2015-12-10) -- "Wooden Christmas-Tree" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Broyden tridiagonal > > library("nleqslv") > > brdtri <- function(x) { + n <- length(x) + y <- numeric(n) + + y[1] <- (3-2*x[1])*x[1] - 2*x[2] + 1 + y[n] <- (3-2*x[n])*x[n] - x[n-1] + 1 + + k <- 2:(n-1) + y[k] <- (3-2*x[k])*x[k] - x[k-1] - 2 * x[k+1] + 1 + + y + } > > n <- 100 > xstart <- -rep(1,n) > ztol <- 1000*.Machine$double.eps > > z1 <- nleqslv(xstart,brdtri, method="Newton") > z2 <- nleqslv(xstart,brdtri, method="Newton", control=list(dsub=1,dsuper=1)) > > cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") z1 termcd= 1 jcnt,fcnt= 4 4 > cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z2 termcd= 1 jcnt,fcnt= 4 4 > z1$message [1] "Function criterion near zero" > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z1$x) [1] TRUE > all.equal(z2$x,z1$x, tolerance=ztol) [1] TRUE > > z1 <- nleqslv(xstart,brdtri, method="Newton") > z2 <- nleqslv(xstart,brdtri, method="Newton", control=list(dsub=1,dsuper=1)) > > cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") z1 termcd= 1 jcnt,fcnt= 4 4 > cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z2 termcd= 1 jcnt,fcnt= 4 4 > z1$message [1] "Function criterion near zero" > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z1$x, tolerance=ztol) [1] TRUE > > z3 <- nleqslv(xstart,brdtri, method="Broyden") > z4 <- nleqslv(xstart,brdtri, method="Broyden", control=list(dsub=1,dsuper=1)) > > cat("z3 termcd=",z1$termcd, "jcnt,fcnt=",z3$njcnt,z3$nfcnt,"\n") z3 termcd= 1 jcnt,fcnt= 1 10 > cat("z4 termcd=",z2$termcd, "jcnt,fcnt=",z4$njcnt,z4$nfcnt,"\n") z4 termcd= 1 jcnt,fcnt= 1 10 > z3$message [1] "x-values within tolerance 'xtol'" > z4$message [1] "x-values within tolerance 'xtol'" > all.equal(z3$x,z1$x) [1] TRUE > all.equal(z4$x,z1$x) [1] TRUE > all.equal(z4$x,z3$x, tolerance=ztol) [1] TRUE > > proc.time() user system elapsed 0.178 0.024 0.193 nleqslv/tests/xtestnslv.Rout0000644000175100001440000000647212711355535016063 0ustar hornikusers R version 3.2.5 Patched (2016-04-18 r70508) -- "Very, Very Secure Dishes" Copyright (C) 2016 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > # function to replace small number with OK or if not with NZ > # this is to avoid differences in the Fnorm column between machines/cpu/os/compilers > > # the test is for checking that testnslv (still) works as expected > > fixsmall <- function(x) { + z <- ifelse(x < .Machine$double.eps^(2/3), "OK","NZ") + z <- ifelse(is.na(z), "NA", z) + z + } > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > xstart <- c(0.5,0.5) > fstart <- dslnex(xstart) > z <- testnslv(xstart,dslnex) > zfn <- z$out[,"Fnorm"] > z$out[,"Fnorm"] <- fixsmall(zfn) > z Call: testnslv(x = xstart, fn = dslnex) Results: Method Global termcd Fcnt Jcnt Iter Message Fnorm 1 Newton cline 1 7 6 6 Fcrit OK 2 Newton qline 1 7 6 6 Fcrit OK 3 Newton gline 1 9 5 5 Fcrit OK 4 Newton pwldog 1 7 6 6 Fcrit OK 5 Newton dbldog 1 7 6 6 Fcrit OK 6 Newton hook 1 7 6 6 Fcrit OK 7 Newton none 1 8 8 8 Fcrit OK 8 Broyden cline 1 12 1 9 Fcrit OK 9 Broyden qline 1 12 1 9 Fcrit OK 10 Broyden gline 1 14 1 10 Fcrit OK 11 Broyden pwldog 1 12 1 10 Fcrit OK 12 Broyden dbldog 1 12 1 10 Fcrit OK 13 Broyden hook 1 12 1 10 Fcrit OK 14 Broyden none 1 13 1 13 Fcrit OK > > # this will encounter an error > xstart <- c(2.0,0.5) > fstart <- dslnex(xstart) > z <- testnslv(xstart,dslnex) Error (method=Newton global=none): non-finite value(s) detected in jacobian (row=2,col=1) > zfn <- z$out[,"Fnorm"] > z$out[,"Fnorm"] <- fixsmall(zfn) > z Call: testnslv(x = xstart, fn = dslnex) Results: Method Global termcd Fcnt Jcnt Iter Message Fnorm 1 Newton cline 1 11 7 7 Fcrit OK 2 Newton qline 1 10 7 7 Fcrit OK 3 Newton gline 1 17 7 7 Fcrit OK 4 Newton pwldog 1 6 5 5 Fcrit OK 5 Newton dbldog 1 6 5 5 Fcrit OK 6 Newton hook 1 11 7 7 Fcrit OK 7 Newton none NA NA NA NA ERROR NA 8 Broyden cline 1 17 1 11 Fcrit OK 9 Broyden qline 1 18 1 13 Fcrit OK 10 Broyden gline 1 25 1 11 Fcrit OK 11 Broyden pwldog 1 12 1 10 Fcrit OK 12 Broyden dbldog 1 12 1 10 Fcrit OK 13 Broyden hook 1 16 1 12 Fcrit OK 14 Broyden none 4 20 1 20 Maxiter NZ > > proc.time() user system elapsed 0.166 0.022 0.178 nleqslv/tests/brdban.R0000644000175100001440000000270212103676167014503 0ustar hornikusers# Broyden banded function library("nleqslv") brdban <- function(x) { ml <- 5 mu <- 1 n <- length(x) y <- numeric(n) for( k in 1:n ) { k1 <- max(1, k - ml) k2 <- min(n, k + mu) temp = 0.0 for(j in k1:k2) { if ( j != k ) { temp <- temp + x[j] * (1.0 + x[j]) } } y[k] <- x[k] * (2.0 + 5.0 * x[k]**2) + 1.0 - temp } y } n <- 10 xstart <- -rep(1,n) xsol <- c( -0.42830, -0.47660, -0.51965, -0.55810, -0.59251, -0.62450, -0.62324, -0.62139, -0.62045, -0.58647 ) fsol <- brdban(xsol) znlq <- nleqslv(xstart, brdban, global="dbldog", method="Newton", control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) znlq$termcd # should be 2 for x values within tolerance all(abs(znlq$fvec)<=1e-7) # may not have achieved ftol xstart <- -2*rep(1,n) znlq <- nleqslv(xstart, brdban, global="dbldog", method="Newton", control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) znlq$termcd all(abs(znlq$fvec)<=1e-8) znlq <- nleqslv(xstart, brdban, global="dbldog", control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) znlq$termcd # should be 2 for x values within tolerance all(abs(znlq$fvec)<=1e-7) # may not have achieved ftol xstart <- -2*rep(1,n) znlq <- nleqslv(xstart, brdban, global="dbldog", control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) znlq$termcd all(abs(znlq$fvec)<=1e-8) nleqslv/tests/xtestnslv.Rout.save0000644000175100001440000000647212711355535017020 0ustar hornikusers R version 3.2.5 Patched (2016-04-18 r70508) -- "Very, Very Secure Dishes" Copyright (C) 2016 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > # function to replace small number with OK or if not with NZ > # this is to avoid differences in the Fnorm column between machines/cpu/os/compilers > > # the test is for checking that testnslv (still) works as expected > > fixsmall <- function(x) { + z <- ifelse(x < .Machine$double.eps^(2/3), "OK","NZ") + z <- ifelse(is.na(z), "NA", z) + z + } > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > xstart <- c(0.5,0.5) > fstart <- dslnex(xstart) > z <- testnslv(xstart,dslnex) > zfn <- z$out[,"Fnorm"] > z$out[,"Fnorm"] <- fixsmall(zfn) > z Call: testnslv(x = xstart, fn = dslnex) Results: Method Global termcd Fcnt Jcnt Iter Message Fnorm 1 Newton cline 1 7 6 6 Fcrit OK 2 Newton qline 1 7 6 6 Fcrit OK 3 Newton gline 1 9 5 5 Fcrit OK 4 Newton pwldog 1 7 6 6 Fcrit OK 5 Newton dbldog 1 7 6 6 Fcrit OK 6 Newton hook 1 7 6 6 Fcrit OK 7 Newton none 1 8 8 8 Fcrit OK 8 Broyden cline 1 12 1 9 Fcrit OK 9 Broyden qline 1 12 1 9 Fcrit OK 10 Broyden gline 1 14 1 10 Fcrit OK 11 Broyden pwldog 1 12 1 10 Fcrit OK 12 Broyden dbldog 1 12 1 10 Fcrit OK 13 Broyden hook 1 12 1 10 Fcrit OK 14 Broyden none 1 13 1 13 Fcrit OK > > # this will encounter an error > xstart <- c(2.0,0.5) > fstart <- dslnex(xstart) > z <- testnslv(xstart,dslnex) Error (method=Newton global=none): non-finite value(s) detected in jacobian (row=2,col=1) > zfn <- z$out[,"Fnorm"] > z$out[,"Fnorm"] <- fixsmall(zfn) > z Call: testnslv(x = xstart, fn = dslnex) Results: Method Global termcd Fcnt Jcnt Iter Message Fnorm 1 Newton cline 1 11 7 7 Fcrit OK 2 Newton qline 1 10 7 7 Fcrit OK 3 Newton gline 1 17 7 7 Fcrit OK 4 Newton pwldog 1 6 5 5 Fcrit OK 5 Newton dbldog 1 6 5 5 Fcrit OK 6 Newton hook 1 11 7 7 Fcrit OK 7 Newton none NA NA NA NA ERROR NA 8 Broyden cline 1 17 1 11 Fcrit OK 9 Broyden qline 1 18 1 13 Fcrit OK 10 Broyden gline 1 25 1 11 Fcrit OK 11 Broyden pwldog 1 12 1 10 Fcrit OK 12 Broyden dbldog 1 12 1 10 Fcrit OK 13 Broyden hook 1 16 1 12 Fcrit OK 14 Broyden none 4 20 1 20 Maxiter NZ > > proc.time() user system elapsed 0.166 0.022 0.178 nleqslv/tests/brdban.Rout0000644000175100001440000000445712250323554015234 0ustar hornikusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Broyden banded function > > library("nleqslv") > > brdban <- function(x) { + ml <- 5 + mu <- 1 + n <- length(x) + y <- numeric(n) + + for( k in 1:n ) { + + k1 <- max(1, k - ml) + k2 <- min(n, k + mu) + + temp = 0.0 + for(j in k1:k2) { + if ( j != k ) { + temp <- temp + x[j] * (1.0 + x[j]) + } + } + + y[k] <- x[k] * (2.0 + 5.0 * x[k]**2) + 1.0 - temp + + } + y + } > > n <- 10 > xstart <- -rep(1,n) > > xsol <- c( -0.42830, -0.47660, -0.51965, -0.55810, -0.59251, + -0.62450, -0.62324, -0.62139, -0.62045, -0.58647 ) > > fsol <- brdban(xsol) > > znlq <- nleqslv(xstart, brdban, global="dbldog", method="Newton", + control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) > znlq$termcd # should be 2 for x values within tolerance [1] 1 > all(abs(znlq$fvec)<=1e-7) # may not have achieved ftol [1] TRUE > > xstart <- -2*rep(1,n) > znlq <- nleqslv(xstart, brdban, global="dbldog", method="Newton", + control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) > znlq$termcd [1] 1 > all(abs(znlq$fvec)<=1e-8) [1] TRUE > > znlq <- nleqslv(xstart, brdban, global="dbldog", + control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) > znlq$termcd # should be 2 for x values within tolerance [1] 1 > all(abs(znlq$fvec)<=1e-7) # may not have achieved ftol [1] TRUE > > xstart <- -2*rep(1,n) > znlq <- nleqslv(xstart, brdban, global="dbldog", + control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) > znlq$termcd [1] 1 > all(abs(znlq$fvec)<=1e-8) [1] TRUE > > proc.time() user system elapsed 0.367 0.051 0.406 nleqslv/tests/singular3.R0000644000175100001440000000157712506462617015173 0ustar hornikusers library(nleqslv) print.result <- function(z, do.print.xf=FALSE) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } # Powell cautionary example # M.J.D. Powell, "A Hybrid Method for Nonlinear Equations", # in Numerical methods for Nonlinear Algebraic Equations, ed. P. Rabinowitz, 1970. f <- function(x) { y <- numeric(2) y[1] <- x[1] y[2] <- 10*x[1]/(x[1]+.1) + 2*x[2]^2 y } jac <- function(x) { fjac <- matrix(0,nrow=2,ncol=2) fjac[1, 1] <- 1 fjac[1, 2] <- 0 fjac[2, 1] <- 1/(x[1]+0.1)^2 fjac[2, 2] <- 4*x[2] fjac } xstart <- c(3,1) z1 <- nleqslv(xstart,f, method="Newton",control=list(trace=0,allowSingular=TRUE)) print.result(z1) xstart <- c(3,0) # singular start z2 <- nleqslv(xstart,f, method="Newton",control=list(trace=0,allowSingular=TRUE)) print.result(z2) nleqslv/tests/xcutlip1p2.Rout0000644000175100001440000000442012572255121016006 0ustar hornikusers R version 3.2.2 Patched (2015-08-25 r69180) -- "Fire Safety" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Steady-State solution for reaction rate equations > # Shacham homotopy method (discrete changing of one or more parameters) > # M. Shacham: Numerical Solution of Constrained Non-linear algebriac equations > # International Journal for Numerical Methods in Engineering, 1986, pp.1455--1481. > > # solution should always be > 0 > > library(nleqslv) > > RNGkind(kind="Wichmann-Hill") > set.seed(123) > > # Problem 2, page 1463/1464 > > cutlip <- function(x) { + # paper has wrong order of parameters + # use the Fortran program to get the correct values + + # parameter set 2 + k1 <- 17.721 + k2 <- 3.483 + k3 <- 505.051 + kr1<- 0.118 + kr2<- 0.033 + + r <- numeric(6) + + r[1] = 1 - x[1] - k1*x[1]*x[6] + kr1 * x[4] + r[2] = 1 - x[2] - k2*x[2]*x[6] + kr2 * x[5] + r[3] = -x[3] + 2*k3*x[4]*x[5] + r[4] = k1*x[1]*x[6] - kr1*x[4] - k3*x[4]*x[5] + r[5] = 1.5*(k2*x[2]*x[6] - kr2*x[5]) - k3*x[4]*x[5] + r[6] = 1 - x[4] - x[5] - x[6] + + r + } > > > Nrep <- 50 > xstart <- matrix(0,nrow=Nrep, ncol=6) > xstart[,1] <- runif(Nrep,min=0,max=2) > xstart[,2] <- runif(Nrep,min=0,max=1) > xstart[,3] <- runif(Nrep,min=0,max=2) > xstart[,4] <- runif(Nrep,min=0,max=1) > xstart[,5] <- runif(Nrep,min=0,max=1) > xstart[,6] <- runif(Nrep,min=0,max=1) > > ans <- searchZeros(xstart,cutlip, method="Broyden",global="dbldog") > nrow(ans$x)==4 [1] TRUE > all(ans$xfnorm <= 1e-10) [1] TRUE > > zans <- searchZeros(ans$xstart,cutlip, method="Broyden",global="dbldog") > length(zans$idxcvg)==4 [1] TRUE > all(ans$xfnorm == zans$xfnorm) [1] TRUE > > proc.time() user system elapsed 0.228 0.020 0.238 nleqslv/tests/dslnexHook.Rout0000644000175100001440000000571512371105450016115 0ustar hornikusers R version 3.1.1 (2014-07-10) -- "Sock it to Me" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > > do.print.xf <- FALSE > do.trace <- 0 > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > xcmp.result <- function(z1,z2) all(abs(z1$x-z2$x) <= 1e-8) > > xstart <- c(2,0.5) > hnlq1 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="cauchy", trace=do.trace)) > hnlq2 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="newton", trace=do.trace)) > print.result(hnlq1) [1] "Function criterion near zero" [1] TRUE > print.result(hnlq2) [1] "Function criterion near zero" [1] TRUE > xcmp.result(hnlq1,hnlq2) [1] TRUE > > dnlq1 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="cauchy", trace=do.trace)) > dnlq2 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="newton", trace=do.trace)) > print.result(dnlq1) [1] "Function criterion near zero" [1] TRUE > print.result(dnlq2) [1] "Function criterion near zero" [1] TRUE > xcmp.result(dnlq1,dnlq2) [1] TRUE > xcmp.result(hnlq1,dnlq1) [1] TRUE > > xstart <- c(1.1,1.1) > hnlq1 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="cauchy", trace=do.trace)) > hnlq2 <- nleqslv(xstart, dslnex, global="hook", control=list(btol=.01,delta="newton", trace=do.trace)) > print.result(hnlq1) [1] "Function criterion near zero" [1] TRUE > print.result(hnlq2) [1] "Function criterion near zero" [1] TRUE > xcmp.result(hnlq1,hnlq2) [1] TRUE > > dnlq1 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="cauchy", trace=do.trace)) > dnlq2 <- nleqslv(xstart, dslnex, global="dbldog", control=list(btol=.01,delta="newton", trace=do.trace)) > print.result(dnlq1) [1] "Function criterion near zero" [1] TRUE > print.result(dnlq2) [1] "Function criterion near zero" [1] TRUE > xcmp.result(dnlq1,dnlq2) [1] TRUE > xcmp.result(hnlq1,dnlq1) [1] TRUE > > proc.time() user system elapsed 0.319 0.048 0.353 nleqslv/tests/xtestnslv.R0000644000175100001440000000141512512424446015320 0ustar hornikusers library(nleqslv) # function to replace small number with OK or if not with NZ # this is to avoid differences in the Fnorm column between machines/cpu/os/compilers # the test is for checking that testnslv (still) works as expected fixsmall <- function(x) { z <- ifelse(x < .Machine$double.eps^(2/3), "OK","NZ") z <- ifelse(is.na(z), "NA", z) z } dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } xstart <- c(0.5,0.5) fstart <- dslnex(xstart) z <- testnslv(xstart,dslnex) zfn <- z$out[,"Fnorm"] z$out[,"Fnorm"] <- fixsmall(zfn) z # this will encounter an error xstart <- c(2.0,0.5) fstart <- dslnex(xstart) z <- testnslv(xstart,dslnex) zfn <- z$out[,"Fnorm"] z$out[,"Fnorm"] <- fixsmall(zfn) z nleqslv/tests/xsearchzeros.Rout.save0000644000175100001440000000314712573011226017452 0ustar hornikusers R version 3.2.2 Patched (2015-08-25 r69180) -- "Fire Safety" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # R. Baker Kearfott, Some tests of Generalized Bisection, > # ACM Transactions on Methematical Software, Vol. 13, No. 3, 1987, pp 197-220 > > # A high-degree polynomial system (section 4.3 Problem 12) > # There are 12 real roots (and 126 complex roots to this system!) > > library(nleqslv) > > hdp <- function(x) { + f <- numeric(length(x)) + f[1] <- 5 * x[1]^9 - 6 * x[1]^5 * x[2]^2 + x[1] * x[2]^4 + 2 * x[1] * x[3] + f[2] <- -2 * x[1]^6 * x[2] + 2 * x[1]^2 * x[2]^3 + 2 * x[2] * x[3] + f[3] <- x[1]^2 + x[2]^2 - 0.265625 + f + } > > > N <- 40 > set.seed(123) > xstart <- matrix(runif(3*N,min=-1,max=1), N, 3) # N starting values, each of length 3 > > ans <- searchZeros(xstart,hdp, method="Broyden",global="dbldog") > nrow(ans$x) == 12 [1] TRUE > all(ans$xfnorm <= 1e-10) [1] TRUE > > zans <- searchZeros(ans$xstart,hdp, method="Broyden",global="dbldog") > length(zans$idxcvg) == 12 [1] TRUE > > proc.time() user system elapsed 0.181 0.021 0.191 nleqslv/tests/dslnexscaled.Rout0000644000175100001440000000533312077324116016451 0ustar hornikusers R version 2.15.2 Patched (2013-01-16 r61667) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis Schnabel example > > library("nleqslv") > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > fstart <- dslnex(xstart) > xstart [1] 2.0 0.5 > fstart [1] 2.2500000 0.8432818 > > # a solution is c(1,1) > > do.print.xf <- FALSE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > # Use our fixed scaling > > znlq <- nleqslv(xstart, dslnex, jacdsln, global="dbldog", control=list(btol=.01,delta=-1.0,chkjac=TRUE,scalex=c(2,3))) > if(znlq$termcd == -10) stop("Internal error in check analytical jacobian") > > # Broyden analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, global=z, control=list(btol=.01,delta=delta,chkjac=TRUE,scalex=c(2,3))) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Newton analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z, control=list(btol=.01,delta=delta,chkjac=TRUE,scalex=c(2,3))) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.252 0.047 0.279 nleqslv/tests/tscalargrad.R0000644000175100001440000000131712751667720015547 0ustar hornikusers# http://r.789695.n4.nabble.com/newton-method-td2306111.html#a2306111 # R-help, 29-07-2010: newton.method library(nleqslv) f <- function(x) 2.5*exp(-0.5*(2*0.045 - x)) + 2.5*exp(-0.045) + 2.5*exp(-1.5*x) - 100 g1 <- function(x) 0.5*2.5*exp(-0.5*(2*0.045 - x)) - 1.5*2.5*exp(-1.5*x) g2 <- function(x) matrix(0.5*2.5*exp(-0.5*(2*0.045 - x)) - 1.5*2.5*exp(-1.5*x), nrow=1,ncol=1) xu.1 <- uniroot(f,c(-3,0), tol=1e-8)$root xu.2 <- uniroot(f,c( 6,8), tol=1e-8)$root xg1.1 <- nleqslv(-2,f,g1)$x xg2.1 <- nleqslv(-2,f,g2)$x xg1.2 <- nleqslv(8,f,g1)$x xg2.2 <- nleqslv(8,f,g2)$x all.equal(xg1.1, xu.1) all.equal(xg1.2, xu.2) all.equal(xg1.2, xg2.2) all.equal(xg2.1, xu.1) all.equal(xg2.2, xu.2) all.equal(xg1.2, xg2.2) nleqslv/tests/brdtri.R0000644000175100001440000000247412250620070014530 0ustar hornikusers# Broyden tridiagonal library("nleqslv") brdtri <- function(x) { n <- length(x) y <- numeric(n) y[1] <- (3-2*x[1])*x[1] - 2*x[2] + 1 y[n] <- (3-2*x[n])*x[n] - x[n-1] + 1 k <- 2:(n-1) y[k] <- (3-2*x[k])*x[k] - x[k-1] - 2 * x[k+1] + 1 y } n <- 100 xstart <- -rep(1,n) ztol <- 1000*.Machine$double.eps z1 <- nleqslv(xstart,brdtri, method="Newton") z2 <- nleqslv(xstart,brdtri, method="Newton", control=list(dsub=1,dsuper=1)) cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z1$message z2$message all.equal(z2$x,z1$x) all.equal(z2$x,z1$x, tolerance=ztol) z1 <- nleqslv(xstart,brdtri, method="Newton") z2 <- nleqslv(xstart,brdtri, method="Newton", control=list(dsub=1,dsuper=1)) cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z1$message z2$message all.equal(z2$x,z1$x, tolerance=ztol) z3 <- nleqslv(xstart,brdtri, method="Broyden") z4 <- nleqslv(xstart,brdtri, method="Broyden", control=list(dsub=1,dsuper=1)) cat("z3 termcd=",z1$termcd, "jcnt,fcnt=",z3$njcnt,z3$nfcnt,"\n") cat("z4 termcd=",z2$termcd, "jcnt,fcnt=",z4$njcnt,z4$nfcnt,"\n") z3$message z4$message all.equal(z3$x,z1$x) all.equal(z4$x,z1$x) all.equal(z4$x,z3$x, tolerance=ztol) nleqslv/tests/dslnexCN.Rout.save0000644000175100001440000000411512360445734016455 0ustar hornikusers R version 3.1.1 (2014-07-10) -- "Sock it to Me" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("nleqslv") > > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > > xstart <- c(2,0.5) > fstart <- dslnex(xstart) > xstart [1] 2.0 0.5 > fstart [1] 2.2500000 0.8432818 > > do.print.xf <- TRUE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > sink("dslnexCN-num.txt") > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta, trace=1)) + print.result(znlq) + } + } > sink() > > sink("dslnexCN-char.txt") > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c("cauchy", "newton") ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta,trace=1)) + print.result(znlq) + } + } > sink() > > z1 <- readLines(con="dslnexCN-num.txt") > z2 <- readLines(con="dslnexCN-char.txt") > > all.equal(z1,z2) [1] TRUE > > proc.time() user system elapsed 0.255 0.051 0.427 nleqslv/tests/brdbanded.Rout0000644000175100001440000000534712250620160015701 0ustar hornikusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Broyden banded > > library("nleqslv") > > brdban <- function(x,ml=5,mu=1) { + n <- length(x) + y <- numeric(n) + + for( k in 1:n ) { + + k1 <- max(1, k - ml) + k2 <- min(n, k + mu) + + temp <- 0.0 + for(j in k1:k2) { + if ( j != k ) { + temp <- temp + x[j] * (1.0 + x[j]) + } + } + + y[k] <- x[k] * (2.0 + 5.0 * x[k]**2) + 1.0 - temp + + } + y + } > > n <- 10 > xstart <- -rep(1,n) > ztol <- 1000*.Machine$double.eps > > z1 <- nleqslv(xstart,brdban, method="Newton") > z2 <- nleqslv(xstart,brdban, method="Newton", control=list(dsub=5,dsuper=1)) > > cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") z1 termcd= 1 jcnt,fcnt= 5 5 > cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z2 termcd= 1 jcnt,fcnt= 5 5 > z1$message [1] "Function criterion near zero" > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z1$x) [1] TRUE > all.equal(z2$x,z1$x, tolerance=ztol) [1] TRUE > > z1 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Newton") > z2 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Newton", control=list(dsub=2,dsuper=2)) > > cat("z1 termcd=",z1$termcd, "jcnt,fcnt=",z1$njcnt,z1$nfcnt,"\n") z1 termcd= 1 jcnt,fcnt= 5 5 > cat("z2 termcd=",z2$termcd, "jcnt,fcnt=",z2$njcnt,z2$nfcnt,"\n") z2 termcd= 1 jcnt,fcnt= 5 5 > z1$message [1] "Function criterion near zero" > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z1$x, tolerance=ztol) [1] TRUE > > z3 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Broyden") > z4 <- nleqslv(xstart,brdban, ml=2,mu=2, method="Broyden", control=list(dsub=2,dsuper=2)) > > cat("z3 termcd=",z1$termcd, "jcnt,fcnt=",z3$njcnt,z3$nfcnt,"\n") z3 termcd= 1 jcnt,fcnt= 1 20 > cat("z4 termcd=",z2$termcd, "jcnt,fcnt=",z4$njcnt,z4$nfcnt,"\n") z4 termcd= 1 jcnt,fcnt= 1 20 > z3$message [1] "Function criterion near zero" > z4$message [1] "Function criterion near zero" > all.equal(z3$x,z1$x) [1] TRUE > all.equal(z4$x,z1$x) [1] TRUE > all.equal(z4$x,z3$x, tolerance=ztol) [1] TRUE > > proc.time() user system elapsed 0.377 0.051 0.415 nleqslv/tests/chquad.Rout0000644000175100001440000000374512103676260015252 0ustar hornikusers R version 2.15.2 Patched (2013-01-21 r61728) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > # Chebyquad functions (no solution for n=8) > > library("nleqslv") > > chebyquad <- function(x) { + n <- length(x) + y <- numeric(n) + + for(j in 1:n) { + t1 <- 1.0 + t2 <- 2.0*x[j] - 1.0 + tmp <- 2.0*t2 + + for(i in 1:n) { + y[i] <- y[i] + t2 + t3 <- tmp * t2 - t1 + t1 <- t2 + t2 <- t3 + } + } + + y = y / n + + for(i in 1:n) { + if ( i%%2 == 0 ) { + y[i] = y[i] + 1.0 / (i * i - 1) + } + } + + y + } > > chebyinit <- function(n) { + x <- (1:n) / (n + 1) + } > > for (n in c(1:7,9)) { # exclude n=8 since there is no solution + xstart <- chebyinit(n) + fstart <- chebyquad(xstart) + + zz <- nleqslv(xstart, chebyquad, global="dbldog", + control=list(ftol=1e-8,xtol=1e-8,trace=0,btol=.01,delta=-2)) + print(all(abs(zz$fvec)<=1e-8)) + } [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE > > for (n in c(1:7,9)) { # exclude n=8 since there is no solution + xstart <- chebyinit(n) + fstart <- chebyquad(xstart) + + zz <- nleqslv(xstart, chebyquad, global="dbldog", method="Newton", + control=list(ftol=1e-8,xtol=1e-8,trace=0,btol=.01,delta=-2)) + print(all(abs(zz$fvec)<=1e-8)) + } [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE [1] TRUE > > proc.time() user system elapsed 0.374 0.046 0.401 nleqslv/tests/singular3.Rout0000644000175100001440000000335212506462667015721 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > print.result <- function(z, do.print.xf=FALSE) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > # Powell cautionary example > # M.J.D. Powell, "A Hybrid Method for Nonlinear Equations", > # in Numerical methods for Nonlinear Algebraic Equations, ed. P. Rabinowitz, 1970. > > > f <- function(x) { + y <- numeric(2) + y[1] <- x[1] + y[2] <- 10*x[1]/(x[1]+.1) + 2*x[2]^2 + + y + } > > jac <- function(x) { + fjac <- matrix(0,nrow=2,ncol=2) + + fjac[1, 1] <- 1 + fjac[1, 2] <- 0 + fjac[2, 1] <- 1/(x[1]+0.1)^2 + fjac[2, 2] <- 4*x[2] + + fjac + } > > xstart <- c(3,1) > z1 <- nleqslv(xstart,f, method="Newton",control=list(trace=0,allowSingular=TRUE)) > print.result(z1) [1] "Function criterion near zero" [1] TRUE > xstart <- c(3,0) # singular start > z2 <- nleqslv(xstart,f, method="Newton",control=list(trace=0,allowSingular=TRUE)) > print.result(z2) [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.155 0.019 0.166 nleqslv/tests/dslnexscaled.Rout.save0000644000175100001440000000533312077324116017406 0ustar hornikusers R version 2.15.2 Patched (2013-01-16 r61667) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis Schnabel example > > library("nleqslv") > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > fstart <- dslnex(xstart) > xstart [1] 2.0 0.5 > fstart [1] 2.2500000 0.8432818 > > # a solution is c(1,1) > > do.print.xf <- FALSE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > # Use our fixed scaling > > znlq <- nleqslv(xstart, dslnex, jacdsln, global="dbldog", control=list(btol=.01,delta=-1.0,chkjac=TRUE,scalex=c(2,3))) > if(znlq$termcd == -10) stop("Internal error in check analytical jacobian") > > # Broyden analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, global=z, control=list(btol=.01,delta=delta,chkjac=TRUE,scalex=c(2,3))) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Newton analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z, control=list(btol=.01,delta=delta,chkjac=TRUE,scalex=c(2,3))) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.252 0.047 0.279 nleqslv/tests/dslnexauto.R0000644000175100001440000000345112371206772015441 0ustar hornikusers# Dennis Schnabel example library("nleqslv") dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } xstart <- c(2,0.5) fstart <- dslnex(xstart) xstart fstart # a solution is c(1,1) do.print.xf <- FALSE print.result <- function(z) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } # Use automatic scaling of x-values. Dosn't always work. # Broyden numerical Jacobian for( z in c("qline", "gline") ) { # quadratic, geometric linesearch znlq <- nleqslv(xstart, dslnex, global=z,xscalm="auto",control=list(btol=.01)) print.result(znlq) } # Broyden numerical Jacobian for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, global=z,xscalm="auto", control=list(btol=.01,delta=delta)) print.result(znlq) } } # Broyden analytical jacobian for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, jacdsln, global=z,xscalm="auto", control=list(btol=.01,delta=delta)) print.result(znlq) } } # Newton analytical jacobian for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z,xscalm="auto", control=list(btol=.01,delta=delta)) print.result(znlq) } } nleqslv/tests/chquad.R0000644000175100001440000000200212103676167014511 0ustar hornikusers # Chebyquad functions (no solution for n=8) library("nleqslv") chebyquad <- function(x) { n <- length(x) y <- numeric(n) for(j in 1:n) { t1 <- 1.0 t2 <- 2.0*x[j] - 1.0 tmp <- 2.0*t2 for(i in 1:n) { y[i] <- y[i] + t2 t3 <- tmp * t2 - t1 t1 <- t2 t2 <- t3 } } y = y / n for(i in 1:n) { if ( i%%2 == 0 ) { y[i] = y[i] + 1.0 / (i * i - 1) } } y } chebyinit <- function(n) { x <- (1:n) / (n + 1) } for (n in c(1:7,9)) { # exclude n=8 since there is no solution xstart <- chebyinit(n) fstart <- chebyquad(xstart) zz <- nleqslv(xstart, chebyquad, global="dbldog", control=list(ftol=1e-8,xtol=1e-8,trace=0,btol=.01,delta=-2)) print(all(abs(zz$fvec)<=1e-8)) } for (n in c(1:7,9)) { # exclude n=8 since there is no solution xstart <- chebyinit(n) fstart <- chebyquad(xstart) zz <- nleqslv(xstart, chebyquad, global="dbldog", method="Newton", control=list(ftol=1e-8,xtol=1e-8,trace=0,btol=.01,delta=-2)) print(all(abs(zz$fvec)<=1e-8)) } nleqslv/tests/dslnexauto.Rout.save0000644000175100001440000000671112052712027017117 0ustar hornikusers R version 2.15.2 (2012-10-26) -- "Trick or Treat" Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis Schnabel example > > library("nleqslv") > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > fstart <- dslnex(xstart) > xstart [1] 2.0 0.5 > fstart [1] 2.2500000 0.8432818 > > # a solution is c(1,1) > > do.print.xf <- FALSE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > # Use automatic scaling of x-values. Dosn't always work. > > # Broyden numerical Jacobian > for( z in c("qline", "gline") ) { # quadratic, geometric linesearch + znlq <- nleqslv(xstart, dslnex, global=z,xscalm="auto",control=list(btol=.01)) + print.result(znlq) + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Broyden numerical Jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, global=z,xscalm="auto", control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "Function criterion near zero" [1] TRUE [1] "No better point found (algorithm has stalled)" [1] FALSE > > # Broyden analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, global=z,xscalm="auto", control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "Function criterion near zero" [1] TRUE [1] "No better point found (algorithm has stalled)" [1] FALSE > > # Newton analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z,xscalm="auto", control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "No better point found (algorithm has stalled)" [1] FALSE > > proc.time() user system elapsed 0.246 0.045 0.278 nleqslv/tests/dslnexauto.Rout0000644000175100001440000000671112052712027016162 0ustar hornikusers R version 2.15.2 (2012-10-26) -- "Trick or Treat" Copyright (C) 2012 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis Schnabel example > > library("nleqslv") > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > fstart <- dslnex(xstart) > xstart [1] 2.0 0.5 > fstart [1] 2.2500000 0.8432818 > > # a solution is c(1,1) > > do.print.xf <- FALSE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > # Use automatic scaling of x-values. Dosn't always work. > > # Broyden numerical Jacobian > for( z in c("qline", "gline") ) { # quadratic, geometric linesearch + znlq <- nleqslv(xstart, dslnex, global=z,xscalm="auto",control=list(btol=.01)) + print.result(znlq) + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Broyden numerical Jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, global=z,xscalm="auto", control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "Function criterion near zero" [1] TRUE [1] "No better point found (algorithm has stalled)" [1] FALSE > > # Broyden analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, global=z,xscalm="auto", control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "Function criterion near zero" [1] TRUE [1] "No better point found (algorithm has stalled)" [1] FALSE > > # Newton analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z,xscalm="auto", control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "No better point found (algorithm has stalled)" [1] FALSE [1] "No better point found (algorithm has stalled)" [1] FALSE > > proc.time() user system elapsed 0.246 0.045 0.278 nleqslv/tests/dslnexjacout.Rout0000644000175100001440000000456412271535720016511 0ustar hornikusers R version 2.15.2 Patched (2013-01-21 r61728) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > library(nleqslv) > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > do.print.xf <- FALSE > do.trace <- 0 > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > xstart <- c(2,.5) > > z <- nleqslv(xstart,dslnex, jacobian=TRUE, control=list(trace=do.trace)) > print.result(z) [1] "Function criterion near zero" [1] TRUE > all.equal(z$jac,jacdsln(z$x), tolerance=0.05) [1] TRUE > > z <- nleqslv(xstart,dslnex,jacdsln, jacobian=TRUE, control=list(trace=do.trace)) > print.result(z) [1] "Function criterion near zero" [1] TRUE > all.equal(z$jac,jacdsln(z$x), tolerance=0.05) [1] TRUE > > z <- nleqslv(xstart,dslnex, method="Newton", jacobian=TRUE, control=list(trace=do.trace)) > print.result(z) [1] "Function criterion near zero" [1] TRUE > all.equal(z$jac,jacdsln(z$x), tolerance=10^3*.Machine$double.eps^0.5) [1] TRUE > > z <- nleqslv(xstart,dslnex, jacdsln, method="Newton", jacobian=TRUE, control=list(trace=do.trace)) > print.result(z) [1] "Function criterion near zero" [1] TRUE > identical(z$jac,jacdsln(z$x)) [1] TRUE > > proc.time() user system elapsed 0.327 0.044 0.367 nleqslv/tests/xsearchzeros.Rout0000644000175100001440000000314712573011226016515 0ustar hornikusers R version 3.2.2 Patched (2015-08-25 r69180) -- "Fire Safety" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin13.4.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # R. Baker Kearfott, Some tests of Generalized Bisection, > # ACM Transactions on Methematical Software, Vol. 13, No. 3, 1987, pp 197-220 > > # A high-degree polynomial system (section 4.3 Problem 12) > # There are 12 real roots (and 126 complex roots to this system!) > > library(nleqslv) > > hdp <- function(x) { + f <- numeric(length(x)) + f[1] <- 5 * x[1]^9 - 6 * x[1]^5 * x[2]^2 + x[1] * x[2]^4 + 2 * x[1] * x[3] + f[2] <- -2 * x[1]^6 * x[2] + 2 * x[1]^2 * x[2]^3 + 2 * x[2] * x[3] + f[3] <- x[1]^2 + x[2]^2 - 0.265625 + f + } > > > N <- 40 > set.seed(123) > xstart <- matrix(runif(3*N,min=-1,max=1), N, 3) # N starting values, each of length 3 > > ans <- searchZeros(xstart,hdp, method="Broyden",global="dbldog") > nrow(ans$x) == 12 [1] TRUE > all(ans$xfnorm <= 1e-10) [1] TRUE > > zans <- searchZeros(ans$xstart,hdp, method="Broyden",global="dbldog") > length(zans$idxcvg) == 12 [1] TRUE > > proc.time() user system elapsed 0.181 0.021 0.191 nleqslv/tests/xnames.Rout.save0000644000175100001440000000243112076331367016231 0ustar hornikusers R version 2.15.2 Patched (2013-01-16 r61667) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > f <- function(x) { + y <-numeric(length(x)) + y[1] <- x[1]^2 + x[2]^3 + y[2] <- x[1] + 2*x[2] + 3 + y + } > > # test named x-values > xstart <- c(a=1.0, b=0.5) > xstart a b 1.0 0.5 > > z <- nleqslv(xstart,f, control=list(trace=0)) > all(names(z$x) == names(xstart)) [1] TRUE > > # test named x-values > xstart <- c(u=1.0, 0.5) > xstart u 1.0 0.5 > > z <- nleqslv(xstart,f, control=list(trace=0)) > all(names(z$x) == names(xstart)) [1] TRUE > > proc.time() user system elapsed 0.325 0.043 0.363 nleqslv/tests/control-try.R0000644000175100001440000000052012624143663015541 0ustar hornikusers library(nleqslv) # Dennis Schnabel example 6.5.1 page 149 f <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } # check error handling in control argument try(nleqslv(f,control=list(1e-3))) try(nleqslv(f,control=list(f=1e-3))) try(nleqslv(f,control=list(f=1e-7,b=1e-3))) nleqslv/tests/singular2.R0000644000175100001440000000256412507302220015147 0ustar hornikusers# http://stackoverflow.com/questions/29134996/solving-nonlinear-equation-in-r # wants to know if system has closed form solution # I want to see how nleqslv behaves set.seed(29) library(nleqslv) print.result <- function(z, do.print.xf=FALSE) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } f <- function(X, a, b, c1, c2, c3) { Y <- numeric(3) x <- X[1] y <- X[2] z <- X[3] Y[1] <- x + y - x*y - c1 Y[2] <- x + z - x*z - c2 Y[3] <- a*y + b*z - c3 return(Y) } Jac <- function(X, a, b, c1, c2, c3) { J <- matrix(0,nrow=3,ncol=3) x <- X[1] y <- X[2] z <- X[3] J[1,1] <- 1-y J[2,1] <- 1-z J[3,1] <- 0 J[1,2] <- 1-x J[2,2] <- 0 J[3,2] <- a J[1,3] <- 0 J[2,3] <- 1-x J[3,3] <- b J } a <- 1 b <- 1 c1 <- 2 c2 <- 3 c3 <- 4 # exact solution x <- (a*c1+b*c2-c3)/(a+b-c3) y <- (b*c1-b*c2-c1*c3+c3)/(-a*c1+a-b*c2+b) z <- (a*(c1-c2)+(c2-1)*c3)/(a*(c1-1)+b*(c2-1)) xsol <- c(x,y,z) X.start <- c(1,2,3) z1 <- nleqslv(X.start,f,Jac,a=a,b=b,c1=c1,c2=c2,c3=c3, method="Newton",control=list(trace=0,allowSingular=TRUE)) z2 <- nleqslv(X.start,f,Jac,a=a,b=b,c1=c1,c2=c2,c3=c3, method="Broyden",control=list(trace=0,allowSingular=TRUE)) all.equal(z1$x,xsol) all.equal(z2$x,xsol) print.result(z1) print.result(z2) nleqslv/tests/singular2.Rout0000644000175100001440000000445112507302267015707 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # http://stackoverflow.com/questions/29134996/solving-nonlinear-equation-in-r > > # wants to know if system has closed form solution > # I want to see how nleqslv behaves > > set.seed(29) > > library(nleqslv) > > print.result <- function(z, do.print.xf=FALSE) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > f <- function(X, a, b, c1, c2, c3) { + Y <- numeric(3) + x <- X[1] + y <- X[2] + z <- X[3] + Y[1] <- x + y - x*y - c1 + Y[2] <- x + z - x*z - c2 + Y[3] <- a*y + b*z - c3 + return(Y) + } > > Jac <- function(X, a, b, c1, c2, c3) { + J <- matrix(0,nrow=3,ncol=3) + x <- X[1] + y <- X[2] + z <- X[3] + + J[1,1] <- 1-y + J[2,1] <- 1-z + J[3,1] <- 0 + J[1,2] <- 1-x + J[2,2] <- 0 + J[3,2] <- a + J[1,3] <- 0 + J[2,3] <- 1-x + J[3,3] <- b + J + } > > a <- 1 > b <- 1 > c1 <- 2 > c2 <- 3 > c3 <- 4 > > # exact solution > x <- (a*c1+b*c2-c3)/(a+b-c3) > y <- (b*c1-b*c2-c1*c3+c3)/(-a*c1+a-b*c2+b) > z <- (a*(c1-c2)+(c2-1)*c3)/(a*(c1-1)+b*(c2-1)) > xsol <- c(x,y,z) > > X.start <- c(1,2,3) > z1 <- nleqslv(X.start,f,Jac,a=a,b=b,c1=c1,c2=c2,c3=c3, + method="Newton",control=list(trace=0,allowSingular=TRUE)) > > z2 <- nleqslv(X.start,f,Jac,a=a,b=b,c1=c1,c2=c2,c3=c3, + method="Broyden",control=list(trace=0,allowSingular=TRUE)) > > all.equal(z1$x,xsol) [1] TRUE > all.equal(z2$x,xsol) [1] TRUE > print.result(z1) [1] "Function criterion near zero" [1] TRUE > print.result(z2) [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.158 0.020 0.170 nleqslv/tests/dslnexjacout.Rout.save0000644000175100001440000000456412271535720017446 0ustar hornikusers R version 2.15.2 Patched (2013-01-21 r61728) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > library(nleqslv) > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > do.print.xf <- FALSE > do.trace <- 0 > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > xstart <- c(2,.5) > > z <- nleqslv(xstart,dslnex, jacobian=TRUE, control=list(trace=do.trace)) > print.result(z) [1] "Function criterion near zero" [1] TRUE > all.equal(z$jac,jacdsln(z$x), tolerance=0.05) [1] TRUE > > z <- nleqslv(xstart,dslnex,jacdsln, jacobian=TRUE, control=list(trace=do.trace)) > print.result(z) [1] "Function criterion near zero" [1] TRUE > all.equal(z$jac,jacdsln(z$x), tolerance=0.05) [1] TRUE > > z <- nleqslv(xstart,dslnex, method="Newton", jacobian=TRUE, control=list(trace=do.trace)) > print.result(z) [1] "Function criterion near zero" [1] TRUE > all.equal(z$jac,jacdsln(z$x), tolerance=10^3*.Machine$double.eps^0.5) [1] TRUE > > z <- nleqslv(xstart,dslnex, jacdsln, method="Newton", jacobian=TRUE, control=list(trace=do.trace)) > print.result(z) [1] "Function criterion near zero" [1] TRUE > identical(z$jac,jacdsln(z$x)) [1] TRUE > > proc.time() user system elapsed 0.327 0.044 0.367 nleqslv/tests/dslnex.Rout.save0000644000175100001440000000656412305674210016236 0ustar hornikusers R version 3.0.3 RC (2014-02-27 r65092) -- "Warm Puppy" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("nleqslv") > > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > fstart <- dslnex(xstart) > xstart [1] 2.0 0.5 > fstart [1] 2.2500000 0.8432818 > > # a solution is c(1,1) > > do.print.xf <- FALSE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > # Broyden numerical Jacobian > for( z in c("cline", "qline", "gline") ) { # cubic, quadratic, geometric linesearch + znlq <- nleqslv(xstart, dslnex, global=z,control=list(btol=.01)) + print.result(znlq) + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Broyden numerical Jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Broyden analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, global=z, control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Newton analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z, control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.319 0.052 0.358 nleqslv/tests/singular3.Rout.save0000644000175100001440000000333412505767436016657 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > print.result <- function(z, do.print.xf=FALSE) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > # Powell cautionary example > # M.J.D. Powell, "A Hybrid Method for Nonlinear Equations", > # in Numerical methods for Nonlinear Algebraic Equations, ed. P. Rabinowitz, 1970. > > > f <- function(x) { + y <- numeric(2) + y[1] <- x[1] + y[2] <- 10*x[1]/(x[1]+.1) + 2*x[2]^2 + + y + } > > jac <- function(x) { + fjac <- matrix(0,nrow=2,ncol=2) + + fjac[1, 1] <- 1 + fjac[1, 2] <- 0 + fjac[2, 1] <- 1/(x[1]+0.1)^2 + fjac[2, 2] <- 4*x[2] + + fjac + } > > xstart <- c(3,1) > z1 <- nleqslv(xstart,f, method="Newton",control=list(trace=0,allowSingular=TRUE)) > print.result(z1) [1] "Function criterion near zero" [1] TRUE > xstart <- c(3,0) # singular start > z2 <- nleqslv(xstart,f, method="Newton",control=list(trace=0,allowSingular=TRUE)) > print.result(z2) [1] "Function criterion near zero" [1] TRUE > nleqslv/tests/xsearchzeros.R0000644000175100001440000000151412573010474015765 0ustar hornikusers# R. Baker Kearfott, Some tests of Generalized Bisection, # ACM Transactions on Methematical Software, Vol. 13, No. 3, 1987, pp 197-220 # A high-degree polynomial system (section 4.3 Problem 12) # There are 12 real roots (and 126 complex roots to this system!) library(nleqslv) hdp <- function(x) { f <- numeric(length(x)) f[1] <- 5 * x[1]^9 - 6 * x[1]^5 * x[2]^2 + x[1] * x[2]^4 + 2 * x[1] * x[3] f[2] <- -2 * x[1]^6 * x[2] + 2 * x[1]^2 * x[2]^3 + 2 * x[2] * x[3] f[3] <- x[1]^2 + x[2]^2 - 0.265625 f } N <- 40 set.seed(123) xstart <- matrix(runif(3*N,min=-1,max=1), N, 3) # N starting values, each of length 3 ans <- searchZeros(xstart,hdp, method="Broyden",global="dbldog") nrow(ans$x) == 12 all(ans$xfnorm <= 1e-10) zans <- searchZeros(ans$xstart,hdp, method="Broyden",global="dbldog") length(zans$idxcvg) == 12 nleqslv/tests/singular1.Rout0000644000175100001440000000333612505767436015722 0ustar hornikusers R version 3.1.3 (2015-03-09) -- "Smooth Sidewalk" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library(nleqslv) > > # Brown almost linear function > > brown <- function(x) { + n <- length(x) + y <- numeric(n) + + y[1:(n-1)] <- x[1:(n-1)] + sum(x[1:n]) - (n + 1) + y[n] <- prod(x[1:n]) - 1.0 + + y + } > > brownjac <- function(x) { + n <- length(x) + J <- matrix(1,nrow=n,ncol=n) + diag(J) <- 2 + xprod <- prod(x) + J[n,] <- xprod/x # exact + J + } > > print.result <- function(z, do.print.xf=FALSE) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > for( m in c("Newton","Broyden") ) { + for( n in c(50,100) ) { + xstart <- rep(1,n)/2 + z <- nleqslv(xstart, brown, brownjac, method="Newton", + control=list(trace=0,ftol=1e-10,delta="cauchy",allowSingular=TRUE)) + print.result(z) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > nleqslv/tests/dslnex.Rout0000644000175100001440000000656412305674210015301 0ustar hornikusers R version 3.0.3 RC (2014-02-27 r65092) -- "Warm Puppy" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("nleqslv") > > # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM > # example 6.5.1 page 149 > > dslnex <- function(x) { + y <- numeric(2) + y[1] <- x[1]^2 + x[2]^2 - 2 + y[2] <- exp(x[1]-1) + x[2]^3 - 2 + y + } > > jacdsln <- function(x) { + n <- length(x) + Df <- matrix(numeric(n*n),n,n) + Df[1,1] <- 2*x[1] + Df[1,2] <- 2*x[2] + Df[2,1] <- exp(x[1]-1) + Df[2,2] <- 3*x[2]^2 + + Df + } > > xstart <- c(2,0.5) > fstart <- dslnex(xstart) > xstart [1] 2.0 0.5 > fstart [1] 2.2500000 0.8432818 > > # a solution is c(1,1) > > do.print.xf <- FALSE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > # Broyden numerical Jacobian > for( z in c("cline", "qline", "gline") ) { # cubic, quadratic, geometric linesearch + znlq <- nleqslv(xstart, dslnex, global=z,control=list(btol=.01)) + print.result(znlq) + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Broyden numerical Jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Broyden analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, global=z, control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > # Newton analytical jacobian > for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg + for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step + znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z, control=list(btol=.01,delta=delta)) + print.result(znlq) + } + } [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.319 0.052 0.358 nleqslv/tests/brdban.Rout.save0000644000175100001440000000445712250323554016171 0ustar hornikusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Broyden banded function > > library("nleqslv") > > brdban <- function(x) { + ml <- 5 + mu <- 1 + n <- length(x) + y <- numeric(n) + + for( k in 1:n ) { + + k1 <- max(1, k - ml) + k2 <- min(n, k + mu) + + temp = 0.0 + for(j in k1:k2) { + if ( j != k ) { + temp <- temp + x[j] * (1.0 + x[j]) + } + } + + y[k] <- x[k] * (2.0 + 5.0 * x[k]**2) + 1.0 - temp + + } + y + } > > n <- 10 > xstart <- -rep(1,n) > > xsol <- c( -0.42830, -0.47660, -0.51965, -0.55810, -0.59251, + -0.62450, -0.62324, -0.62139, -0.62045, -0.58647 ) > > fsol <- brdban(xsol) > > znlq <- nleqslv(xstart, brdban, global="dbldog", method="Newton", + control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) > znlq$termcd # should be 2 for x values within tolerance [1] 1 > all(abs(znlq$fvec)<=1e-7) # may not have achieved ftol [1] TRUE > > xstart <- -2*rep(1,n) > znlq <- nleqslv(xstart, brdban, global="dbldog", method="Newton", + control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) > znlq$termcd [1] 1 > all(abs(znlq$fvec)<=1e-8) [1] TRUE > > znlq <- nleqslv(xstart, brdban, global="dbldog", + control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) > znlq$termcd # should be 2 for x values within tolerance [1] 1 > all(abs(znlq$fvec)<=1e-7) # may not have achieved ftol [1] TRUE > > xstart <- -2*rep(1,n) > znlq <- nleqslv(xstart, brdban, global="dbldog", + control=list(trace=0,ftol=1e-8,xtol=1e-8,btol=1e-2,delta=-1.0)) > znlq$termcd [1] 1 > all(abs(znlq$fvec)<=1e-8) [1] TRUE > > proc.time() user system elapsed 0.367 0.051 0.406 nleqslv/tests/xcutlip1p2.R0000644000175100001440000000266612572255072015275 0ustar hornikusers# Steady-State solution for reaction rate equations # Shacham homotopy method (discrete changing of one or more parameters) # M. Shacham: Numerical Solution of Constrained Non-linear algebriac equations # International Journal for Numerical Methods in Engineering, 1986, pp.1455--1481. # solution should always be > 0 library(nleqslv) RNGkind(kind="Wichmann-Hill") set.seed(123) # Problem 2, page 1463/1464 cutlip <- function(x) { # paper has wrong order of parameters # use the Fortran program to get the correct values # parameter set 2 k1 <- 17.721 k2 <- 3.483 k3 <- 505.051 kr1<- 0.118 kr2<- 0.033 r <- numeric(6) r[1] = 1 - x[1] - k1*x[1]*x[6] + kr1 * x[4] r[2] = 1 - x[2] - k2*x[2]*x[6] + kr2 * x[5] r[3] = -x[3] + 2*k3*x[4]*x[5] r[4] = k1*x[1]*x[6] - kr1*x[4] - k3*x[4]*x[5] r[5] = 1.5*(k2*x[2]*x[6] - kr2*x[5]) - k3*x[4]*x[5] r[6] = 1 - x[4] - x[5] - x[6] r } Nrep <- 50 xstart <- matrix(0,nrow=Nrep, ncol=6) xstart[,1] <- runif(Nrep,min=0,max=2) xstart[,2] <- runif(Nrep,min=0,max=1) xstart[,3] <- runif(Nrep,min=0,max=2) xstart[,4] <- runif(Nrep,min=0,max=1) xstart[,5] <- runif(Nrep,min=0,max=1) xstart[,6] <- runif(Nrep,min=0,max=1) ans <- searchZeros(xstart,cutlip, method="Broyden",global="dbldog") nrow(ans$x)==4 all(ans$xfnorm <= 1e-10) zans <- searchZeros(ans$xstart,cutlip, method="Broyden",global="dbldog") length(zans$idxcvg)==4 all(ans$xfnorm == zans$xfnorm) nleqslv/tests/trig.Rout0000644000175100001440000000275212103676261014750 0ustar hornikusers R version 2.15.2 Patched (2013-01-21 r61728) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("nleqslv") > > # Trigonometric function > trig <- function(x) { + n <- length(x) + y <- cos(x) + s <- sum(y) + y <- n - s + c(1:n) * (1-y) - sin(x) + + y + } > > trigjac <- function(x) { + n <- length(x) + J <- matrix(numeric(n*n),n,n) + + for (p in 1:n) { + J[,p] <- sin(x[p]) + J[p,p] <- (p+1) * sin(x[p]) - cos(x[p]) + } + + J + } > > do.print.xf <- FALSE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > n <- 10 > xstart <- rep(1,n)/n > fstart <- trig(xstart) > > znlm <- nleqslv(xstart, trig, global="dbldog", control=list(trace=0)) > print.result(znlm) [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.242 0.046 0.269 nleqslv/tests/brdtrijac.Rout0000644000175100001440000000426512301444213015736 0ustar hornikusers R version 3.0.2 Patched (2014-01-27 r64897) -- "Frisbee Sailing" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-apple-darwin10.8.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # Broyden banded function > > library(nleqslv) > > brdtri <- function(x) { + n <- length(x) + y <- numeric(n) + + # y[1] <- (3-2*x[1])*x[1] - 2*x[2] + 1 + # y[n] <- (3-2*x[n])*x[n] - x[n-1] + 1 + # + # k <- 2:(n-1) + # y[k] <- (3-2*x[k])*x[k] - x[k-1] - 2 * x[k+1] + 1 + # + y <- (3-2*x)*x - c(0,x[-n]) - 2*c(x[-1],0) + 1 + y + } > > brdtrijac <- function(x) { + n <- length(x) + J <- diag(3-4*x,n,n) + J[row(J)==col(J)+1] <- -1 + J[row(J)==col(J)-1] <- -2 + J + } > > options(echo=TRUE) > > n <- 10 > xstart <- -rep(1,n) > fstart <- brdtri(xstart) > > z0 <- nleqslv(xstart,brdtri, method="Newton", global="dbldog") > z0$message [1] "Function criterion near zero" > > z1 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0)) > z1$message [1] "Function criterion near zero" > all.equal(z1$x,z0$x) [1] TRUE > > z2 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,chkjac=TRUE)) > z2$message [1] "Function criterion near zero" > all.equal(z2$x,z0$x) [1] TRUE > > z3 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,dsub=1,dsuper=1)) > z3$message [1] "Function criterion near zero" > all.equal(z2$x,z0$x) [1] TRUE > > z4 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,dsub=1,dsuper=1,chkjac=TRUE)) > z4$message [1] "Function criterion near zero" > all.equal(z2$x,z0$x) [1] TRUE > > proc.time() user system elapsed 0.309 0.050 0.346 nleqslv/tests/dslnexCN.R0000644000175100001440000000231412371206772014766 0ustar hornikusers library("nleqslv") # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } xstart <- c(2,0.5) fstart <- dslnex(xstart) xstart fstart do.print.xf <- TRUE print.result <- function(z) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } sink("dslnexCN-num.txt") for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta, trace=1)) print.result(znlq) } } sink() sink("dslnexCN-char.txt") for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c("cauchy", "newton") ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta,trace=1)) print.result(znlq) } } sink() z1 <- readLines(con="dslnexCN-num.txt") z2 <- readLines(con="dslnexCN-char.txt") all.equal(z1,z2) nleqslv/tests/brdtrijac.R0000644000175100001440000000225412371206772015217 0ustar hornikusers# Broyden banded function library(nleqslv) brdtri <- function(x) { n <- length(x) y <- numeric(n) # y[1] <- (3-2*x[1])*x[1] - 2*x[2] + 1 # y[n] <- (3-2*x[n])*x[n] - x[n-1] + 1 # # k <- 2:(n-1) # y[k] <- (3-2*x[k])*x[k] - x[k-1] - 2 * x[k+1] + 1 # y <- (3-2*x)*x - c(0,x[-n]) - 2*c(x[-1],0) + 1 y } brdtrijac <- function(x) { n <- length(x) J <- diag(3-4*x,n,n) J[row(J)==col(J)+1] <- -1 J[row(J)==col(J)-1] <- -2 J } options(echo=TRUE) n <- 10 xstart <- -rep(1,n) fstart <- brdtri(xstart) z0 <- nleqslv(xstart,brdtri, method="Newton", global="dbldog") z0$message z1 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0)) z1$message all.equal(z1$x,z0$x) z2 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,chkjac=TRUE)) z2$message all.equal(z2$x,z0$x) z3 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,dsub=1,dsuper=1)) z3$message all.equal(z2$x,z0$x) z4 <- nleqslv(xstart,brdtri, brdtrijac, method="Newton", global="dbldog",control=list(trace=0,dsub=1,dsuper=1,chkjac=TRUE)) z4$message all.equal(z2$x,z0$x) nleqslv/tests/dslnex.R0000644000175100001440000000346112371206772014551 0ustar hornikusers library("nleqslv") # Dennis & Schnabel,1996,"Numerical methods for unconstrained optimization and nonlinear equations", SIAM # example 6.5.1 page 149 dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } xstart <- c(2,0.5) fstart <- dslnex(xstart) xstart fstart # a solution is c(1,1) do.print.xf <- FALSE print.result <- function(z) { if( do.print.xf ) { print(z$x) print(z$fvec) } print(z$message) print(all(abs(z$fvec)<=1e-8)) } # Broyden numerical Jacobian for( z in c("cline", "qline", "gline") ) { # cubic, quadratic, geometric linesearch znlq <- nleqslv(xstart, dslnex, global=z,control=list(btol=.01)) print.result(znlq) } # Broyden numerical Jacobian for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, global=z, control=list(btol=.01,delta=delta)) print.result(znlq) } } # Broyden analytical jacobian for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, jacdsln, global=z, control=list(btol=.01,delta=delta)) print.result(znlq) } } # Newton analytical jacobian for( z in c("dbldog","pwldog") ) { # double dogleg, Powell (single) dogleg for( delta in c(-1.0, -2.0) ) { # Cauchy step , Newton step znlq <- nleqslv(xstart, dslnex, jacdsln, method="Newton", global=z, control=list(btol=.01,delta=delta)) print.result(znlq) } } nleqslv/tests/trig.Rout.save0000644000175100001440000000275212103676261015705 0ustar hornikusers R version 2.15.2 Patched (2013-01-21 r61728) -- "Trick or Treat" Copyright (C) 2013 The R Foundation for Statistical Computing ISBN 3-900051-07-0 Platform: x86_64-apple-darwin9.8.0/x86_64 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("nleqslv") > > # Trigonometric function > trig <- function(x) { + n <- length(x) + y <- cos(x) + s <- sum(y) + y <- n - s + c(1:n) * (1-y) - sin(x) + + y + } > > trigjac <- function(x) { + n <- length(x) + J <- matrix(numeric(n*n),n,n) + + for (p in 1:n) { + J[,p] <- sin(x[p]) + J[p,p] <- (p+1) * sin(x[p]) - cos(x[p]) + } + + J + } > > do.print.xf <- FALSE > > print.result <- function(z) { + if( do.print.xf ) { + print(z$x) + print(z$fvec) + } + print(z$message) + print(all(abs(z$fvec)<=1e-8)) + } > > n <- 10 > xstart <- rep(1,n)/n > fstart <- trig(xstart) > > znlm <- nleqslv(xstart, trig, global="dbldog", control=list(trace=0)) > print.result(znlm) [1] "Function criterion near zero" [1] TRUE > > proc.time() user system elapsed 0.242 0.046 0.269 nleqslv/src/0000755000175100001440000000000013126751064012550 5ustar hornikusersnleqslv/src/lautil.f0000644000175100001440000001203413127132302014176 0ustar hornikusers c----------------------------------------------------------------------------- subroutine liqrfa(a, lda, n, tau, work, wsiz, info) integer lda, n, wsiz, info double precision a(lda,*), tau(*), work(*) c------------------------------------------------------------- c c QR decomposition of A(n,n) c c Arguments c c Inout A Real(Lda,n) Matrix to transform. c In lda Integer Leading dimension of A c In n Integer number of rows/cols A c Out tau Real(n) Information for recovering c Out work Real(*) workspace c In wsiz Integer size of work() c Lapack blocked QR (much faster for larger n) c c------------------------------------------------------------- call dgeqrf(n,n,A,lda,tau,work,wsiz,info) return end c============================================================= subroutine liqsiz(n,wrksiz) integer n, wrksiz c------------------------------------------------------------------------- c Query the size of the double precision work array required c for optimal operation of the Lapack QR routines c------------------------------------------------------------------------- double precision A(1), work(1) integer lwork, info lwork = -1 call dgeqrf(n,n,A,n,work,work,lwork,info) if( info .ne. 0 ) then wrksiz = -1 else wrksiz = int(work(1)) endif return end c============================================================= subroutine liqrqt(a, lda, n, tau, qty, work, wsiz, info) integer lda, n, wsiz, info double precision a(lda,*), tau(*), qty(*), work(*) c------------------------------------------------------------- c Arguments c c In A Real(Lda, n) QR decomposition c In Lda Integer Leading dimension A c In n Integer Number of rows/columns in A c In tau Integer Householder constants from QR c Inout qty Real(n) On input, vector y c On output, trans(Q)*y c Out work Real(*) workspace c In wsiz Integer size of work() c c Liqrqt calculates trans(Q)*y from the QR decomposition c c Lapack blocked c------------------------------------------------------------- call dormqr('L','T',n,1,n,A,lda,tau,qty,n,work,wsiz,info) return end c============================================================= subroutine liqrqq(q,ldq,tau,n,work,wsiz,info) integer n, ldq, wsiz, info double precision q(ldq,*),tau(*),work(*) c Arguments c c Inout Q Real(ldq,*) On input, QR decomposition c On output, the full Q c In ldq Integer leading dimension of Q c In tau Real(n) Householder constants of c the QR decomposition c In n Integer number of rows/columns in Q c Out work Real(n) workspace of length n c In wsiz Integer size of work() c c Generate Q from QR decomposition Liqrfa (dgeqr2) c c Lapack blocked c------------------------------------------------------------- call dorgqr(n,n,n,q,ldq,tau,work,wsiz,info) return end c----------------------------------------------------------------------------- subroutine nuzero(n,x) integer n double precision x(*) c Parameters: c c In n Integer Number of elements. c In x Real(*) Vector of reals. c c Description: c c Nuzero sets all elements of x to 0. c Does nothing when n <= 0 double precision Rzero parameter(Rzero=0.0d0) integer i do i=1,n x(i) = Rzero enddo return end c ---------------------------------------------------------------------- subroutine nuvgiv(x,y,c,s) double precision x,y,c,s c Parameters c c Inout x Real x input / c*x+s*y on output c Inout y Real y input / 0 on output c Out c Real c of tranformation (cosine) c Out s Real s of tranformation ( sine) c c Description c c Nuvgiv calculates the givens rotator c c | c s | c G = | | c | -s c | c c with c*c+s*s=1 c c for which G * | x | = | t | c | y | | 0 | c c resulting in c c c * x + s * y = t c -s * x + c * y = 0 ==> s/c = y/x or c/s = x/y c c Use Lapack dlartg routine c return c and s and the modified x and y c This differs from dlartg which does not modify input arguments. c See http://www.netlib.org/lapack/explore-html/dd/d24/dlartg_8f_source.html c c * x + s * y may differ from t with machine precision double precision t double precision Rzero parameter(Rzero=0.0d0) call dlartg(x,y,c,s,t) x = t y = Rzero return end nleqslv/src/Makevars0000644000175100001440000000014613127132302014232 0ustar hornikusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) # used when checking ###PKG_FFLAGS = -fimplicit-none nleqslv/src/nwout.c0000755000175100001440000001624113127132302014064 0ustar hornikusers #include #include #include #include static int jacsng = -1; static int jacupd = -1; static double jacond = 0.0; /* * output for a single incorrect jacobian entry */ void F77_SUB(nwckot)(int *i, int *j, double *aij, double *wi) { Rprintf("Chkjac possible error in jacobian[%d,%d] = %20.13e\n" " Estimated[%d,%d] = %20.13e\n", *i, *j, *aij, *i, *j, *wi); } #if 0 /* for debugging */ void F77_SUB(prmunjac)(double *mu) { Rprintf("nwnjac mu=%g\n",*mu); } void F77_SUB(prmubjac)(double *mu) { Rprintf("nwbjac mu=%g\n",*mu); } void F77_SUB(praifal1)(double *aifnrm, double *al1nrm) { Rprintf("aifnrm=%g al1nrm=%g\n",*aifnrm,*al1nrm); } #endif void F77_SUB(nwsnot)(int *jtype, int *ierr, double *rcond) { /* * save for later printing */ jacsng = *ierr; jacupd = *jtype; jacond = *rcond; } double getjacond() { return(jacond); } /* * output a compact description of the type of the jacobian used * Newton/Broyden followed by lowercase letter for ill-conditioned/singular * estimated inverse condition number * * sprintf on Windows seems to use 3 digits for the exponent by default (msvcrt.dll?) * and doesn't obey the %7.1e format (uses 8.1) * that messes up a nice layout */ static void nwrowhdr(int *iter) { char jmethod; Rprintf( " %4d ", *iter); if( jacupd < 0) { /* output padding */ Rprintf("%11s",""); } else { jmethod = (jacupd == 0) ? 'N' : 'B'; /* * meaning jacsng * 0 jacobian is ok (not singular or ill-conditioned) * 1 jacobian is ill-conditioned * 2 jacobian is singular * * Indicate this after output of */ if( jacsng == 0 ) Rprintf(" %c(%7.1e)", jmethod, jacond); else if( jacsng == 1 ) Rprintf("%ci(%7.1e)", jmethod, jacond); else Rprintf("%cs%9s", jmethod,""); /* * avoid output of redundant information on next time called */ jacupd = -1; } } void F77_SUB(nwjerr)(int *iter) { nwrowhdr(iter); Rprintf("\n"); } /* * output trust region size within width 8 * (sometimes it is too large for %8.4f) */ static void dnumout(double x) { if(x >= 1000.0) Rprintf(" %8.*e", x >= 1e100? 1 : 2, x); else Rprintf(" %8.4f",x); } static void enumout(double x) { Rprintf(" %13.*e", fabs(x) >= 1e100? 5 : 6, x); } static void znumout(int retcd, double x) { char marker; marker = (retcd == 3) ? '*' : ' '; Rprintf("%c%13.*e", marker, fabs(x) >= 1e100? 5 : 6, x); } #if 0 /* for debugging */ void F77_SUB(xclshpar)(int *gcnt, double *slope, double *a, double *b, double *disc, double *dbp2, double *t, double *t1,double *t2) { Rprintf("Clsh: gcnt=%d, slope=%g, a=%g, b=%g, disc=%g, disc-b^2= %d, t=%g t1=%g t2=%g\n",*gcnt, *slope, *a, *b, *disc, *dbp2>0, *t,*t1,*t2); } #endif void F77_SUB(nwprot)(int *iter, int *lstep, double *oarg) { /* * None global method output */ double v; if( *lstep <= 0 ) { if( *lstep == -1) Rprintf(" %4s %11s %8s %13s %13s\n", "Iter","Jac","Lambda","Fnorm","Largest |f|"); Rprintf(" %4d%22s %13.6e %13.6e\n" , *iter, "", oarg[0],oarg[1]); } else { nwrowhdr(iter); v = *oarg; if( fabs(v) > 0.0001 ) Rprintf( " %8.4f ",v); else Rprintf( " %8.1e ",v); enumout(oarg[1]); enumout(oarg[2]); Rprintf("\n"); } } void F77_SUB(nwlsot)(int *iter, int *lstep, double *oarg) { /* * Linesearch output */ double v; if( *lstep <= 0 ) { if( *lstep == -1) Rprintf(" %4s %11s %8s %13s %13s %13s\n", "Iter","Jac","Lambda","Ftarg","Fnorm","Largest |f|"); Rprintf(" %4d%36s %13.6e %13.6e\n" , *iter, "", oarg[0],oarg[1]); } else { nwrowhdr(iter); v = *oarg; if( fabs(v) > 0.0001 ) Rprintf( " %8.4f ",v); else Rprintf( " %8.1e ",v); enumout(oarg[1]); enumout(oarg[2]); enumout(oarg[3]); Rprintf("\n"); } } void F77_SUB(dgdbg)(double *gamma, double *numerator, double *denominator) { Rprintf("gamma=%g numerator=%g denominator=%g\n", *gamma, *numerator, *denominator); } void F77_SUB(nwdgot)(int *iter, int *lstep, int *retcd, double *oarg) { /* * Double dogleg output */ char step; /* * C gradient (cauchy) step * N newton step * P partial newton step * W convex combination of P and C */ if( *lstep <= 0 ) { if( *lstep == -1) Rprintf(" %4s %11s %8s %8s %8s %8s %13s %13s\n", "Iter","Jac","Lambda", "Eta", "Dlt0", "Dltn", "Fnorm","Largest |f|"); Rprintf(" %4d%50s" , *iter, ""); enumout(oarg[0]); enumout(oarg[1]); Rprintf("\n"); } else { nwrowhdr(iter); step = "CWPN"[*lstep-1]; Rprintf( " %c ", step); if( *lstep == 2 ) Rprintf( "%8.4f", oarg[0]); else Rprintf( "%8s", ""); Rprintf(" %8.4f", oarg[3]); dnumout(oarg[1]); dnumout(oarg[2]); znumout(*retcd, oarg[4]); enumout(oarg[5]); Rprintf("\n"); } } void F77_SUB(nwpwot)(int *iter, int *lstep, int *retcd, double *oarg) { /* * Single dogleg output */ char step; /* * C gradient (cauchy) step * N newton step * W convex combination of P and C */ if( *lstep <= 0 ) { if( *lstep == -1) Rprintf(" %4s %11s %8s %8s %8s %13s %13s\n", "Iter","Jac","Lambda", "Dlt0", "Dltn", "Fnorm","Largest |f|"); Rprintf(" %4d%41s", *iter, ""); enumout(oarg[0]); enumout(oarg[1]); Rprintf("\n"); } else { nwrowhdr(iter); step = "CWN"[*lstep-1]; Rprintf( " %c ", step); if( *lstep == 2 ) Rprintf( "%8.4f",oarg[0]); else Rprintf( "%8s", ""); dnumout(oarg[1]); dnumout(oarg[2]); znumout(*retcd, oarg[3]); enumout(oarg[4]); Rprintf("\n"); } } void F77_SUB(nwmhot)(int *iter, int *lstep, int *retcd, double *oarg) { /* * More-Hebden-Levenberg-Marquardt output */ char step; /* * H MHLM (hook)step * N newton step */ if( *lstep <= 0 ) { if( *lstep == -1) Rprintf(" %4s %11s %8s %8s %8s %8s %13s %13s\n", "Iter","Jac","mu", "dnorm", "Dlt0", "Dltn", "Fnorm","Largest |f|"); Rprintf(" %4d%50s" , *iter, ""); enumout(oarg[0]); enumout(oarg[1]); Rprintf("\n"); } else { nwrowhdr(iter); step = "HN"[*lstep-1]; Rprintf( " %c ", step); if( *lstep == 1 ) Rprintf( "%8.4f", oarg[0]); else Rprintf( "%8s", ""); Rprintf(" %8.4f", oarg[3]); dnumout(oarg[1]); dnumout(oarg[2]); znumout(*retcd, oarg[4]); enumout(oarg[5]); Rprintf("\n"); } } nleqslv/src/nwqlsh.f0000755000175100001440000000757513127132302014241 0ustar hornikusers subroutine nwqlsh(n,xc,fcnorm,d,g,stepmx,xtol,scalex,fvec, * xp,fp,fpnorm,xw,retcd,gcnt,priter,iter) integer n,retcd,gcnt double precision stepmx,xtol,fcnorm,fpnorm double precision xc(*) double precision d(*),g(*),xp(*),fp(*),xw(*) double precision scalex(*) external fvec integer priter,iter c------------------------------------------------------------------------- c c Find a next acceptable iterate using a safeguarded quadratic line search c along the newton direction c c Arguments c c In n Integer dimension of problem c In xc Real(*) current iterate c In fcnorm Real 0.5 * || f(xc) ||**2 c In d Real(*) newton direction c In g Real(*) gradient at current iterate c In stepmx Real maximum stepsize c In xtol Real relative step size at which c successive iterates are considered c close enough to terminate algorithm c In scalex Real(*) diagonal scaling matrix for x() c In fvec Name name of routine to calculate f() c In xp Real(*) new x() c In fp Real(*) new f(x) c In fpnorm Real .5*||fp||**2 c Out xw Real(*) workspace for unscaling x(*) c c Out retcd Integer return code c 0 new satisfactory x() found c 1 no satisfactory x() found c sufficiently distinct from xc() c c Out gcnt Integer number of steps taken c In priter Integer >0 unit if intermediate steps to be printed c -1 if no printing c c------------------------------------------------------------------------- integer i double precision alpha,slope,rsclen,oarg(4) double precision lambda,lamhi,lamlo,t double precision ddot,dnrm2, nudnrm, ftarg double precision dlen integer idamax parameter (alpha = 1.0d-4) double precision Rone, Rtwo, Rten parameter(Rone=1.0d0, Rtwo=2.0d0, Rten=10.0d0) c safeguard initial step size dlen = dnrm2(n,d,1) if( dlen .gt. stepmx ) then lamhi = stepmx / dlen else lamhi = Rone endif c compute slope = g-trans * d slope = ddot(n,g,1,d,1) c compute the smallest value allowable for the damping c parameter lambda ==> lamlo rsclen = nudnrm(n,d,xc) lamlo = xtol / rsclen c initialization of retcd and lambda (linesearch length) retcd = 2 lambda = lamhi gcnt = 0 do while( retcd .eq. 2 ) c compute next x do i=1,n xp(i) = xc(i) + lambda*d(i) enddo c evaluate functions and the objective function at xp call nwfvec(xp,n,scalex,fvec,fp,fpnorm,xw) gcnt = gcnt + 1 ftarg = fcnorm + alpha * lambda * slope if( priter .gt. 0) then oarg(1) = lambda oarg(2) = ftarg oarg(3) = fpnorm oarg(4) = abs(fp(idamax(n,fp,1))) call nwlsot(iter,1,oarg) endif c test whether the standard step produces enough decrease c of the objective function. c If not update lambda and compute a new next iterate if( fpnorm .le. ftarg ) then retcd = 0 else t = ((-lambda**2)*slope/Rtwo)/(fpnorm-fcnorm-lambda*slope) lambda = max(lambda / Rten , t) if(lambda .lt. lamlo) then retcd = 1 endif endif enddo return end nleqslv/src/nwnleq.f0000755000175100001440000003036513127132302014222 0ustar hornikusers subroutine nwnleq(x0,n,scalex,maxit, * jacflg,xtol,ftol,btol,cndtol,method,global, * xscalm,stepmx,delta,sigma,rjac,ldr, * rwork,lrwork, * rcdwrk,icdwrk,qrwork,qrwsiz,fjac,fvec,outopt,xp, * fp,gp,njcnt,nfcnt,iter,termcd) integer n,jacflg(*),maxit,njcnt,nfcnt,iter,termcd,method integer global,xscalm,ldr,lrwork,qrwsiz integer outopt(*) double precision xtol,ftol,btol,cndtol,stepmx,delta,sigma double precision xp(*),fp(*),gp(*),x0(*) double precision rjac(ldr,*),rwork(*),rcdwrk(*),qrwork(*) double precision scalex(*) integer icdwrk(*) external fjac,fvec c------------------------------------------------------------------------- c c Solves systems of nonlinear equations using the Newton / Broyden c method with a global strategy either linesearch or double dogleg c c In x0 Real(*) starting vector for x c In n Integer dimension of problem c Inout scalex Real(*) scaling factors x() c Inout maxit Integer maximum number iterations c Inout jacflg Integer(*) jacobian flag array c jacflg[1]: 0 numeric; 1 user supplied; 2 numerical banded c 3: user supplied banded c jacflg[2]: number of sub diagonals or -1 if not banded c jacflg[3]: number of super diagonals or -1 if not banded c jacflg[4]: 1 if adjusting step allowed when c singular or illconditioned c Inout xtol Real x tolerance c Inout ftol Real f tolerance c Inout btol Real x tolerance for backtracking c Inout cndtol Real tolerance of test for ill conditioning c Inout method Integer method to use c 0 Newton c 1 Broyden c In global Integer global strategy to use c 1 cubic linesearch c 2 quadratic linesearch c 3 geometric linesearch c 4 double dogleg c 5 powell dogleg c 6 hookstep (More-Hebden Levenberg-Marquardt) c In xscalm Integer scaling method c 0 scale fixed and supplied by user c 1 for scale from jac. columns a la Minpack c Inout stepmx Real maximum stepsize c Inout delta Real trust region radius c > 0.0 or special value for initial value c -1.0 ==> use min(Cauchy length, stepmx) c -2.0 ==> use min(Newton length, stepmx) c Inout sigma Real reduction factor geometric linesearch c Inout rjac Real(ldr,*) workspace jacobian c 2*n*n for Broyden and n*n for Newton c In ldr Integer leading dimension rjac c Out rwork Real(*) real workspace (9n) c In lrwork Integer size real workspace c In rcdwrk Real(*) workspace for Dtrcon (3n) c In icdwrk Integer(*) workspace for Dtrcon (n) c In qrwork Real(*) workspace for Lapack QR routines (call liqsiz) c In qrwsiz Integer size of qrwork c In fjac Name optional name of routine to calculate c user supplied jacobian c In fvec Name name of routine to calculate f(x) c In outopt Integer(*) output options c outopt(1) c 0 no output c 1 output an iteration report c outopt(2) c 0 do not check any user supplied jacobian c 1 check user supplied jacobian if supplied c Out xp Real(*) final values for x() c Out fp Real(*) final values for f(x) c Out gp Real(*) gradient of f() at xp() c Out njcnt Integer number of jacobian evaluations c Out nfcnt Integer number of function evaluations c Out iter Integer number of (outer) iterations c Out termcd Integer termination code c > 0 process terminated c 1 function criterion near zero c 2 no better point found c 3 x-values within tolerance c 4 iteration limit exceeded c 5 singular/ill-conditioned jacobian c 6 totally singular jacobian c (when allowSingular=TRUE) c c < 0 invalid input parameters c -1 n not positive c -2 insufficient workspace rwork c -3 cannot check user supplied jacobian (not supplied) c c The subroutine fvec must be declared as c c! subroutine fvec(x,f,n,flag) c double precision x(*), f(*) c integer n, flag c c x() are the x values for which to calculate the function values f(*) c The dimension of these vectors is n c The flag argument is set to c 0 for calculation of function values c >0 indicating that jacobian column is being computed c so that fvec can abort. c c The subroutine fjac must be declared as c c! subroutine mkjac(rjac,ldr,x,n) c integer ldr c double precision rjac(ldr,*), x(*) c integer n c c The routine calculates the jacobian in point x(*) of the c function. If any illegal values are encountered during c calculation of the jacobian it is the responsibility of c the routine to quit. c------------------------------------------------------------------------- double precision epsm c check input parameters call nwpchk(n,lrwork,xtol,ftol,btol,cndtol,maxit, * jacflg,method,global,stepmx,delta,sigma, * epsm,outopt,scalex,xscalm,termcd) if(termcd .lt. 0) then return endif c first argument of nwsolv/brsolv is leading dimension of rjac in those routines c should be at least n if( method .eq. 0 ) then call nwsolv(ldr,x0,n,scalex,maxit,jacflg, * xtol,ftol,btol,cndtol,global,xscalm, * stepmx,delta,sigma, * rjac, * rwork(1 ),rwork(1+ n), * rwork(1+2*n),rwork(1+3*n), * rwork(1+4*n),rwork(1+5*n), * rwork(1+6*n),rwork(1+7*n), * rwork(1+8*n),rcdwrk,icdwrk,qrwork,qrwsiz,epsm, * fjac,fvec,outopt,xp,fp,gp,njcnt,nfcnt,iter,termcd) elseif( method .eq. 1 ) then call brsolv(ldr,x0,n,scalex,maxit,jacflg, * xtol,ftol,btol,cndtol,global,xscalm, * stepmx,delta,sigma, * rjac,rjac(1,n+1), * rwork(1 ),rwork(1+ n), * rwork(1+2*n),rwork(1+3*n), * rwork(1+4*n),rwork(1+5*n), * rwork(1+6*n),rwork(1+7*n), * rwork(1+8*n),rcdwrk,icdwrk, * qrwork,qrwsiz,epsm, * fjac,fvec,outopt,xp,fp,gp,njcnt,nfcnt,iter,termcd) endif return end c----------------------------------------------------------------------- subroutine nwpchk(n,lrwk, * xtol,ftol,btol,cndtol,maxit,jacflg,method, * global,stepmx,delta,sigma,epsm,outopt, * scalex,xscalm,termcd) integer n,lrwk,jacflg(*) integer method,global,maxit,xscalm,termcd integer outopt(*) double precision xtol,ftol,btol,cndtol,stepmx,delta,sigma,epsm double precision scalex(*) c------------------------------------------------------------------------- c c Check input arguments for consistency and modify if needed/harmless c c Arguments c c In n Integer dimension of problem c In lrwk Integer size real workspace c Inout xtol Real x tolerance c Inout ftol Real f tolerance c Inout btol Real x tolerance for backtracking c Inout cndtol Real tolerance of test for ill conditioning c Inout maxit Integer maximum number iterations c Inout jacflg Integer(*) jacobian flag c Inout method Integer method to use (Newton/Broyden) c Inout global Integer global strategy to use c Inout stepmx Real maximum stepsize c Inout delta Real trust region radius c Inout sigma Real reduction factor geometric linesearch c Out epsm machine precision c Inout scalex Real(*) scaling factors x() c Inout xscalm integer 0 for fixed scaling, 1 for automatic scaling c Out termcd Integer termination code (<0 on errors) c c------------------------------------------------------------------------- integer i,len double precision epsmch, dblhuge, Rhuge double precision Rzero, Rone, Rtwo, Rthree parameter(Rzero=0.0d0, Rone=1.0d0, Rtwo=2.0d0, Rthree=3.0d0) double precision Rhalf parameter(Rhalf = 0.5d0) c check that parameters only take on acceptable values c if not, set them to default values c initialize termcd to all ok termcd = 0 c compute machine precision epsm = epsmch() c get largest double precision number Rhuge = dblhuge() c check dimensions of the problem if(n .le. 0) then termcd = -1 return endif c check dimensions of workspace arrays len = 9*n c +2*n*n if(lrwk .lt. len) then termcd = -2 return endif c check jacflg, method, and global if(jacflg(1) .gt. 3 .or. jacflg(1) .lt. 0) jacflg(1) = 0 if(method .lt. 0 .or. method .gt. 1) method = 0 if(global .lt. 0 .or. global .gt. 6) global = 4 c set outopt to correct values if(outopt(1) .ne. 0 ) then outopt(1) = 1 endif if(outopt(2) .ne. 0 ) then outopt(2) = 1 endif c check scaling scale matrices if(xscalm .eq. 0) then do i = 1,n if(scalex(i) .lt. Rzero) scalex(i) = -scalex(i) if(scalex(i) .eq. Rzero) scalex(i) = Rone enddo else xscalm = 1 do i = 1,n scalex(i) = Rone enddo endif c check step and function tolerances if(xtol .lt. Rzero) then xtol = epsm**(Rtwo/Rthree) endif if(ftol .lt. Rzero) then ftol = epsm**(Rtwo/Rthree) endif if( btol .lt. xtol ) btol = xtol cndtol = max(cndtol, epsm) c check reduction in geometric linesearch if( sigma .le. Rzero .or. sigma .ge. Rone ) then sigma = Rhalf endif c check iteration limit if(maxit .le. 0) then maxit = 150 endif c set stepmx if(stepmx .le. Rzero) stepmx = Rhuge c check delta if(delta .le. Rzero) then if( delta .ne. -Rtwo ) then delta = -Rone endif elseif(delta .gt. stepmx) then delta = stepmx endif return end nleqslv/src/lirslv.f0000644000175100001440000000600313127132302014216 0ustar hornikusersc----------------------------------------------------------------------- subroutine lirslv(R,ldr,n,cndtol, stepadj, * qtf,dn,ierr,rcond, rcdwrk,icdwrk) integer ldr,n,ierr double precision cndtol,R(ldr,*) double precision dn(*),qtf(*) double precision rcdwrk(*) integer icdwrk(*) double precision rcond logical stepadj c----------------------------------------------------------------------- c c Solve R * dn = -qtf safely with quard against ill-conditioning c c Arguments c c Inout R Real(ldr,*) upper triangular matrix from QR c if ill conditioned result from liqrev c Levenberg-Marquardt correction c Warning: lower triangular part of R destroyed c In ldr Integer leading dimension of R c In n Integer dimension of problem c In cndtol Real tolerance of test for ill conditioning c In stepadj Logical allow adjusting step for singular/illconditioned jacobian c In qtf Real(*) trans(Q)*f() c Out dn Real(*) Newton direction c Out ierr Integer 0 indicating Jacobian not ill-conditioned or singular c 1 indicating Jacobian ill-conditioned c 2 indicating Jacobian completely singular c 3 indicating almost zero LM correction c Out rcond Real inverse condition of upper triangular R of QR c Wk rcdwrk Real(*) workspace c Wk icdwrk Integer(*) workspace c c----------------------------------------------------------------------- integer k double precision Rone parameter(Rone=1.0d0) double precision mu c check for singularity or ill conditioning call cndjac(n,R,ldr,cndtol,rcond,rcdwrk,icdwrk,ierr) if( ierr .eq. 0 ) then c Normal Newton step c solve Jacobian*dn = -fn c ==> R*dn = - qtf call dcopy(n,qtf,1,dn,1) call dtrsv('U','N','N',n,r,ldr,dn,1) call dscal(n, -Rone, dn, 1) elseif( stepadj ) then c Adjusted Newton step c approximately from pseudoinverse(Jac+) c use mu to solve (trans(R)*R + mu*I*mu*I) * x = - trans(R) * fn c directly from the QR decomposition of R stacked with mu*I c a la Levenberg-Marquardt call compmu(R,ldr,n,mu,rcdwrk,ierr) if( ierr .eq. 0 ) then call liqrev(n,R,ldr,mu,qtf,dn, * rcdwrk(1+n),rcdwrk(2*n+1)) call dscal(n, -Rone, dn, 1) c copy lower triangular R to upper triangular do k=1,n call dcopy (n-k+1,R(k,k),1,R(k,k),ldr) R(k,k) = rcdwrk(1+n+k-1) enddo endif endif return end nleqslv/src/nwpure.f0000755000175100001440000000447613127132302014242 0ustar hornikusers subroutine nwpure(n,xc,d,stepmx,scalex,fvec, * xp,fp,fpnorm,xw,retcd,gcnt,priter,iter) integer n,retcd,gcnt double precision stepmx,fpnorm double precision xc(*) double precision d(*),xp(*),fp(*),xw(*) double precision scalex(*) external fvec integer priter,iter c------------------------------------------------------------------------- c c Find a next iterate using geometric line search c along the newton direction c c Arguments c c In n Integer dimension of problem c In xc Real(*) current iterate c In d Real(*) newton direction c In stepmx Real maximum stepsize c In scalex Real(*) diagonal scaling matrix for x() c In fvec Name name of routine to calculate f() c In xp Real(*) new x() c In fp Real(*) new f(x) c In fpnorm Real .5*||fp||**2 c Out xw Real(*) workspace for unscaling x c c Out retcd Integer return code c 0 new satisfactory x() found (!always) c c Out gcnt Integer number of steps taken c In priter Integer >0 if intermediate steps to be printed c -1 if no printing c c------------------------------------------------------------------------- integer i double precision oarg(3) double precision lambda double precision dnrm2 double precision dlen integer idamax double precision Rone parameter(Rone=1.0d0) c safeguard initial step size dlen = dnrm2(n,d,1) if( dlen .gt. stepmx ) then lambda = stepmx / dlen else lambda = Rone endif retcd = 0 gcnt = 1 c compute the next iterate xp do i=1,n xp(i) = xc(i) + lambda*d(i) enddo c evaluate functions and the objective function at xp call nwfvec(xp,n,scalex,fvec,fp,fpnorm,xw) if( priter .gt. 0) then oarg(1) = lambda oarg(2) = fpnorm oarg(3) = abs(fp(idamax(n,fp,1))) call nwprot(iter,1,oarg) endif return end nleqslv/src/nwglsh.f0000755000175100001440000000747313127132302014224 0ustar hornikusers subroutine nwglsh(n,xc,fcnorm,d,g,sigma,stepmx,xtol,scalex,fvec, * xp,fp,fpnorm,xw,retcd,gcnt,priter,iter) integer n,retcd,gcnt double precision sigma,stepmx,xtol,fcnorm,fpnorm double precision xc(*) double precision d(*),g(*),xp(*),fp(*),xw(*) double precision scalex(*) external fvec integer priter,iter c------------------------------------------------------------------------- c c Find a next acceptable iterate using geometric line search c along the newton direction c c Arguments c c In n Integer dimension of problem c In xc Real(*) current iterate c In fcnorm Real 0.5 * || f(xc) ||**2 c In d Real(*) newton direction c In g Real(*) gradient at current iterate c In sigma Real reduction factor for lambda c In stepmx Real maximum stepsize c In xtol Real relative step size at which c successive iterates are considered c close enough to terminate algorithm c In scalex Real(*) diagonal scaling matrix for x() c In fvec Name name of routine to calculate f() c In xp Real(*) new x() c In fp Real(*) new f(x) c In fpnorm Real .5*||fp||**2 c Out xw Real(*) workspace for unscaling x c c Out retcd Integer return code c 0 new satisfactory x() found c 1 no satisfactory x() found c sufficiently distinct from xc() c c Out gcnt Integer number of steps taken c In priter Integer >0 if intermediate steps to be printed c -1 if no printing c c------------------------------------------------------------------------- integer i double precision alpha,slope,rsclen,oarg(4) double precision lambda,lamhi,lamlo double precision ddot,dnrm2, nudnrm, ftarg double precision dlen integer idamax parameter (alpha = 1.0d-4) double precision Rone parameter(Rone=1.0d0) c safeguard initial step size dlen = dnrm2(n,d,1) if( dlen .gt. stepmx ) then lamhi = stepmx / dlen else lamhi = Rone endif c compute slope = g-trans * d slope = ddot(n,g,1,d,1) c compute the smallest value allowable for the damping c parameter lambda ==> lamlo rsclen = nudnrm(n,d,xc) lamlo = xtol / rsclen c initialization of retcd and lambda (linesearch length) retcd = 2 lambda = lamhi gcnt = 0 do while( retcd .eq. 2 ) c compute next x do i=1,n xp(i) = xc(i) + lambda*d(i) enddo c evaluate functions and the objective function at xp call nwfvec(xp,n,scalex,fvec,fp,fpnorm,xw) gcnt = gcnt + 1 ftarg = fcnorm + alpha * lambda * slope if( priter .gt. 0) then oarg(1) = lambda oarg(2) = ftarg oarg(3) = fpnorm oarg(4) = abs(fp(idamax(n,fp,1))) call nwlsot(iter,1,oarg) endif c test if the standard step produces enough decrease c of the objective function. c If not update lambda and compute a new next iterate if( fpnorm .le. ftarg ) then retcd = 0 else lambda = sigma * lambda if(lambda .lt. lamlo) then retcd = 1 endif endif enddo return end nleqslv/src/nwtrup.f0000755000175100001440000001263313127132302014253 0ustar hornikusers subroutine nwtrup(n,fcnorm,g,sc,nwtstep,stepmx,xtol,delta, * fpred,retcd,xprev,fpnsav,fprev,xp,fp, * fpnorm) integer n,retcd double precision fcnorm,stepmx,xtol,delta,fpred,fpnsav,fpnorm double precision xp(*),g(*) double precision sc(*),xprev(*),fprev(*),fp(*) logical nwtstep c------------------------------------------------------------------------- c c Decide whether to accept xp=xc+sc as the next iterate c and updates the trust region delta c c Arguments c c In n Integer size of xc() c In fcnorm Real .5*||f(xc)||**2 c In g Real(*) gradient at xc() c In sc Real(*) current step c In nwtstep Logical true if sc is newton direction c In stepmx Real maximum step size c In xtol Real minimum step tolerance c Inout delta Real trust region radius c In fpred Real predicted value of .5*||f()||**2 c c Inout retcd Integer return code c 0 xp accepted as next iterate; c delta trust region for next iteration. c c 1 xp unsatisfactory but c accepted as next iterate because c xp-xc .lt. smallest allowable c step length. c c 2 f(xp) too large. c continue current iteration with c new reduced delta. c c 3 f(xp) sufficiently small, but c quadratic model predicts f(xp) c sufficiently well to continue current c iteration with new doubled delta. c c On first entry, retcd must be 4 c c Wk xprev Real(*) (internal) work c Wk fpnsav Real (internal) work c Wk fprev Real(*) (internal) work c Inout xp Real(*) new iterate x() c Inout fp Real(*) new f(xp) c Inout fpnorm Real new .5*||f(xp)||**2 c c------------------------------------------------------------------------- double precision ared,pred,slope,sclen,rln,dltmp double precision dnrm2,ddot,nudnrm logical ret3ok double precision Rone, Rtwo, Rthree, Rfour, Rten double precision Rhalf, Rpten parameter(Rpten = 0.1d0) parameter(Rhalf=0.5d0) parameter(Rone=1.0d0, Rtwo=2.0d0, Rthree=3.0d0, Rfour=4.0d0) parameter(Rten=10.0d0) double precision Rp99,Rp4, Rp75 parameter(Rp99=Rone-Rten**(-2), Rp4=Rten**(-4), Rp75=Rthree/Rfour) double precision alpha parameter(alpha = Rp4) c pred measures the predicted reduction in the function value ared = fpnorm - fcnorm pred = fpred - fcnorm slope = ddot(n,g,1,sc,1) if(retcd .ne. 3) then ret3ok = .false. else ret3ok = fpnorm .ge. fpnsav .or. ared .gt. alpha * slope endif if(retcd .eq. 3 .and. ret3ok) then c reset xp,fp,fpnorm to saved values and terminate global step retcd = 0 call dcopy(n,xprev,1,xp,1) call dcopy(n,fprev,1,fp,1) fpnorm = fpnsav c reset delta to initial value c but beware c if the trial step was a Newton step then delta is reset to c .5 * length(Newton step) which will be smaller c because delta is set to length(Newton step) elsewhere c see nwddlg.f and nwpdlg.f delta = Rhalf*delta elseif(ared .gt. alpha * slope) then c fpnorm too large (decrease not sufficient) rln = nudnrm(n,sc,xp) if(rln .lt. xtol) then c cannot find satisfactory xp sufficiently distinct from xc retcd = 1 else c reduce trust region and continue current global step retcd = 2 sclen = dnrm2(n,sc,1) dltmp = -slope*sclen/(Rtwo*(ared-slope)) if(dltmp .lt. Rpten*delta) then delta = Rpten*delta else delta = min(Rhalf*delta, dltmp) endif endif elseif(retcd .ne. 2 .and. (abs(pred-ared) .le. Rpten*abs(ared)) * .and. (.not. nwtstep) .and. (delta .le. Rp99*stepmx)) then c pred predicts ared very well c attempt a doubling of the trust region and continue global step c when not taking a newton step and trust region not at maximum call dcopy(n,xp,1,xprev,1) call dcopy(n,fp,1,fprev,1) fpnsav = fpnorm delta = min(Rtwo*delta,stepmx) retcd = 3 else c fpnorm sufficiently small to accept xp as next iterate. c Choose new trust region. retcd = 0 if(ared .ge. Rpten*pred) then c Not good enough. Decrease trust region for next iteration delta = Rhalf*delta elseif( ared .le. Rp75*pred ) then c Wonderful. Increase trust region for next iteration delta = min(Rtwo*delta,stepmx) endif endif return end nleqslv/src/liqrev.f0000644000175100001440000001430713127132302014213 0ustar hornikusers c----------------------------------------------------------------------------- subroutine liqrev(n,r,ldr,diag,b,x,sdiag,wrk) integer n,ldr double precision r(ldr,*),b(*),x(*),sdiag(*),wrk(*) double precision diag c----------------------------------------------------------------------------- c c Arguments c c In n Integer order of R. c Inout R Real(ldr,*) upper triangular matrix R from QR c unaltered c strict lower triangle contains c transposed strict upper triangle of the upper c triangular matrix S. c c In diag Real scalar for matrix D c c In ldr Integer leading dimension of the array R. c In b Real(*) vector of size n c c Out x Real(*) vector of size n c on output contains least squares solution c of the system R*x = b, D*x = 0. c c Out sdiag Real(*) vector of size n, containing the c diagonal elements of the upper c triangular matrix S. c c Out wrk Real(*) workspace of size n. c c Description c c Given an n by n upper triangular matrix R, a diagonal matrix D with positive entries c and an n-vector b, determine an x which solves the system c c |R*x| = |b| c |D*x| = |0| c c in the least squares sense where D=diag*I. c This routine can be used for two different purposes. c The first is to provide a method of slightly modifying a singular or ill-conditioned matrix. c The second is for calculating a least squares solution to the above problem within c the context of e.g. a Levenberg-Marquardt algorithm combined with a More-Hebden algorithm c to determine a value of D (diagonal mu) such that x has a predetermined 2-norm. c c The routine could also be used when the matrix R from the QR decomposition of a Jacobian c is ill-conditioned (or singular). Then it is difficult to calculate a Newton step c accurately (Dennis and Schnabel). D&S advise perturbing trans(J)*J with a positive c diagonal matrix. c c The idea is to solve (J^T * J + mu*I)x=b where mu is a small positive number. c Calculation of mu must be done in the calling routine. c Using a QR decomposition of J solving this system c is equivalent solving (R^T*R + mu*I)x=b, where R comes from the QR decomposition. c Solving this system is equivalent to solving the above least squares problem with the c elements of the matrix D set to sqrt(mu) which should be done in the calling routine. c c On output the routine also provides an upper triangular matrix S such that c (see description of arguments above for the details) c c (trans(R)*R + D*D) = trans(S)*S . c c Method used here is described in c Nocedal and Wright, 2006, Numerical Optimization, Springer, ISBN 978-0-387-30303-1 c page 258--261 (second edition) c----------------------------------------------------------------------------- integer j,k double precision bj,c,s,sum,temp double precision ddot double precision Rzero parameter(Rzero=0.0d0) c copy R and b to preserve input and initialise S. c Save the diagonal elements of R in wrk. c Beware: the algorithm operates on an upper triangular matrix, c which is stored in lower triangle of R. c do j=1,n call dcopy(n-j+1,r(j,j),ldr,r(j,j),1) wrk(j) = r(j,j) enddo call dcopy(n,b,1,x,1) c eliminate the diagonal matrix D using givens rotations. c Nocedal method: start at the bottom right c at end of loop R contains diagonal of S c save in sdiag and restore original diagonal of R do j=n,1,-1 c initialise the row of D to be eliminated call nuzero(n-j+1,sdiag(j)) sdiag(j) = diag c the transformations to eliminate the row of D bj = Rzero do k=j,n c determine a givens rotation which eliminates the c appropriate element in the current row of D. c accumulate the transformation in the row of S. c eliminate the diagonal element in row j of D c this generates fill-in in columns [j+1 .. n] of row j of D c successively eliminate the fill-in with givens rotations c for R[j+1,j+1] and D[j,j+1]. c rows of R have been copied into the columns of R initially (see above) c perform all operations on those columns to preserve the original R if (sdiag(k) .ne. Rzero) then call nuvgiv(r(k,k),sdiag(k),c,s) if( k .lt. n ) then call drot(n-k,r(k+1,k),1,sdiag(k+1),1,c,s) endif c compute the modified element of (b,0). temp = c*x(k) + s*bj bj = -s*x(k) + c*bj x(k) = temp endif enddo enddo c retrieve diagonal of S from diagonal of R c restore original diagonal of R do k=1,n sdiag(k) = r(k,k) r(k,k) = wrk(k) enddo c x now contains modified b c solve trans(S)*x = x c still to be done: guard against division by 0 to be absolutely safe c call dblepr('liqrev sdiag', 12, sdiag, n) x(n) = x(n) / sdiag(n) do j=n-1,1,-1 sum = ddot(n-j,r(j+1,j),1,x(j+1),1) x(j) = (x(j) - sum)/sdiag(j) enddo return end c ---------------------------------------------------------------------- subroutine dtrstt(S,ldr,n,sdiag,x) integer ldr, n double precision S(ldr,*), sdiag(*), x(*) integer j double precision sum, ddot c solve S*x = x where x is the result from subroutine liqrev c S is a lower triangular matrix with diagonal entries in sdiag() c and here it is in the lower triangular part of R as returned by liqrev x(1) = x(1) / sdiag(1) do j=2,n sum = ddot(j-1,S(j,1),n,x,1) x(j) = (x(j) - sum)/sdiag(j) enddo return end nleqslv/src/limhpar.f0000644000175100001440000000627413127132302014351 0ustar hornikusers subroutine limhpar(R, ldr, n, sdiag, qtf, dn, dnlen, * glen, delta, mu, d, work) integer ldr, n double precision R(ldr,*), sdiag(*) double precision qtf(*),dn(*), dnlen, glen, d(*),work(*) double precision delta, mu c----------------------------------------------------------------------------- c c Arguments c c Inout R Real(ldr,*) upper triangular matrix R from QR (unaltered) c strict lower triangle contains c transposed strict upper triangle of the upper c triangular matrix S. c c In n Integer order of R. c c In ldr Integer leading dimension of the array R. c c Out sdiag Real(*) vector of size n, containing the c diagonal elements of the upper c triangular matrix S. c c In qtr Real(*) trans(Q)*f vector of size n c In dn Real(*) Newton step c In dnlen Real length Newton step c In glen Real length gradient vector c c Inout mu Real Levenberg-Marquardt parameter c In delta Real size of trust region (euclidian norm) c c Out d Real(*) vector with step with norm very close to delta c Out work Real(*) workspace of size n. c c Description c c determine Levenberg-Marquardt parameter mu such that c norm[(R**T R + mu*I)**(-1) * qtf] - delta approximately 0 c See description in liqrev.f for further details c c Algorithm comes from More: The Levenberg-Marquardt algorithm, Implementation and Theory c Lecture Notes in Mathematics, 1978, no. 630. c uses liqrev (in file liqrev.f) which is based on Nocedal's method (see comments in file) c----------------------------------------------------------------------------- double precision phi, pnorm, qnorm, mulo, muhi,dmu, sqmu integer iter logical done double precision dnrm2 double precision Rone parameter(Rone=1.0D0) phi = dnlen - delta muhi = glen/delta call dcopy(n,dn,1,d,1) call dscal(n, Rone/dnlen, d, 1) c solve R**T * x = dn call dtrsv("U","T","N",n,R,ldr,d,1) qnorm = dnrm2(n,d,1) mulo = (phi/dnlen)/qnorm**2 mu = mulo iter = 0 done = .false. do while( .not. done ) iter = iter + 1 sqmu = sqrt(mu) call liqrev(n, R, ldr, sqmu, qtf, d, sdiag, work) pnorm = dnrm2(n,d,1) call dcopy(n,d,1,work,1) call dtrstt(R, ldr, n, sdiag, work) done = abs(pnorm-delta) .le. .1d0*delta .or. iter .gt. 5 if( .not. done ) then qnorm = dnrm2(n,work,1) if( pnorm .gt. delta ) then mulo = max(mulo,mu) else if( pnorm .lt. delta ) then muhi = min(muhi,mu) endif dmu = (pnorm-delta)/delta * (pnorm/qnorm)**2 mu = max(mulo, mu + dmu) endif enddo return end nleqslv/src/nleqslv.c0000644000175100001440000004345413127132302014377 0ustar hornikusers#include #include extern double getjacond(); typedef struct opt_struct { SEXP x; SEXP fcall; /* function */ SEXP jcall; /* jacobian */ SEXP env; /* environment in which to evaluate calls */ SEXP names; /* names of starting values */ int dsub; /* number of subdiagonals if jacobian is banded */ int dsuper;/* number of superdiagonals if jacobian is banded */ } opt_struct, *OptStruct; OptStruct OS; /* * set to 1 if main function called * used to check for a recursive call * which is not allowed (for the time being) */ static int activeflag = 0; void deactivatenleq(void); /* called on.exit; see .R code */ void fcnval(double *xc, double *fc, int *n, int *flag); void fcnjac(double *rjac, int *ldr, double *x, int *n); void F77_NAME(nwnleq)(double *x, int *n, double *scalex, int *maxit, int *jacflg, double *xtol, double *ftol, double *btol, double *cndtol, int *method, int *global, int *xscalm, double *stepmx, double *delta, double *sigma, double *rjac, int *ldr, double *rwork, int *lrwork, double *rcdwrk, int *icdwrk, double *qrwork, int *qrwsiz, void (*fcnjac)(double *rjac, int *ldr, double *x, int *n), void (*fcnval)(double *xc, double *fc, int *n, int *flag), int *outopt, double *xp, double *fp, double *gp, int *njcnt, int *nfcnt, int *iter, int *termcd); void F77_NAME(liqsiz)(int *n, int *wrksiz); /* returns size of optimal QR work memory */ void deactivatenleq(void) { activeflag = 0; } static SEXP getListElement(SEXP list, char *str) { SEXP elmt = R_NilValue, names = getAttrib(list, R_NamesSymbol); int i; for (i = 0; i < length(list); i++) if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0) { elmt = VECTOR_ELT(list, i); break; } return elmt; } static double *real_vector(int n) { return (double*) R_alloc(n, sizeof(double)); } static int *int_vector(int n) { return (int*) R_alloc(n, sizeof(int)); } static void trace_header(int method, int global, int xscalm, double sigma, double delta, double stepmx, double ftol, double xtol, double btol, double cndtol) { /* print header for iteration tracing output for documentation purposes */ Rprintf(" Algorithm parameters\n --------------------\n"); Rprintf(" Method: %s", method == 1 ? "Broyden" : "Newton"); Rprintf(" Global strategy: "); switch(global) { case 0: Rprintf("none\n"); break; case 1: Rprintf("cubic linesearch\n"); break; case 2: Rprintf("quadratic linesearch\n"); break; case 3: Rprintf("geometric linesearch (reduction = %g)\n", sigma); break; case 4: Rprintf("double dogleg (initial trust region = %g)\n", delta); break; case 5: Rprintf("single dogleg (initial trust region = %g)\n", delta); break; case 6: Rprintf("More/Hebden/Lev/Marquardt (initial trust region = %g)\n", delta); break; default: error("Internal: invalid global value in trace_header\n"); } Rprintf(" Maximum stepsize = %g\n", stepmx <= 0.0 ? DBL_MAX : stepmx); Rprintf(" Scaling: %s\n", xscalm == 0 ? "fixed" : "automatic"); Rprintf(" ftol = %g xtol = %g btol = %g cndtol = %g\n\n", ftol,xtol,btol,cndtol); Rprintf(" Iteration report\n ----------------\n"); } static char *fcn_message(char *msg, int termcd) { switch(termcd) { case 1: sprintf(msg, "Function criterion near zero"); break; case 2: sprintf(msg, "x-values within tolerance 'xtol'"); break; case 3: sprintf(msg, "No better point found (algorithm has stalled)"); break; case 4: sprintf(msg, "Iteration limit exceeded"); break; case 5: sprintf(msg, "Jacobian is too ill-conditioned (1/condition=%7.1e) (see allowSingular option)",getjacond()); break; case 6: sprintf(msg, "Jacobian is singular (1/condition=%7.1e) (see allowSingular option)",getjacond()); break; case 7: sprintf(msg, "Jacobian is completely unusable (all zero entries?)"); break; case -10: sprintf(msg, "User supplied Jacobian most likely incorrect"); break; default: sprintf(msg, "'termcd' == %d should *NEVER* be returned! Please report bug to .", termcd); } return msg; } #define max(a,b) ((a)>(b) ? (a):(b)) #define min(a,b) ((a)<(b) ? (a):(b)) static int findcol(int row, int n, int k) { int j, col = 0; for(j=k; j <= n; j += OS->dsub+OS->dsuper+1) { if( row >= max(j-OS->dsuper,1) && row <= min(j+OS->dsub,n) ) col = j; break; } return col; } /* * interface to user supplied R function * (*flag) == 0 when function is called for function values only * (*flag) > 0 jacobian column number when function is called for numeric jacobian * > *n (*flag-*n) is strip number for banded evaluation */ void fcnval(double *x, double *fc, int *n, int *flag) { int i; SEXP sexp_fvec; for (i = 0; i < *n; i++) { if (!R_FINITE(x[i])) error("non-finite value for `x[%d]` supplied to function\n",i+1); REAL(OS->x)[i] = x[i]; } SETCADR(OS->fcall, OS->x); PROTECT(sexp_fvec = eval(OS->fcall, OS->env)); if(!isReal(sexp_fvec)) error("function must return a numeric vector"); if(LENGTH(sexp_fvec) != *n) error("function return should be a vector of length %d but is of length %d\n", LENGTH(sexp_fvec), *n); for (i = 0; i < *n; i++) { fc[i] = REAL(sexp_fvec)[i]; if( !R_FINITE(fc[i]) ) { fc[i] = sqrt(DBL_MAX / (double)(*n)); /* should force backtracking */ if( *flag ) { if( *flag <= *n ) error("non-finite value(s) detected in jacobian (row=%d,col=%d)",i+1,*flag); else error("non-finite value(s) detected in banded jacobian (row=%d,col=%d)",i+1, findcol(i+1,*n,*flag-*n)); } } } UNPROTECT(1); } void FCNJACDUM(double *rjac, int *ldr, double *x, int *n) { error("FCNJACDUM should not have been called"); } /* * interface to user supplied jacobian function */ void fcnjac(double *rjac, int *ldr, double *x, int *n) { int i, j; SEXP sexp_fjac; SEXP jdims; for (i = 0; i < *n; i++) { if (!R_FINITE(x[i])) error("non-finite value for `x[%d]` supplied to jacobian function\n",i+1); REAL(OS->x)[i] = x[i]; } SETCADR(OS->jcall, OS->x); PROTECT(sexp_fjac = eval(OS->jcall, OS->env)); jdims = getAttrib(sexp_fjac,R_DimSymbol); /* test jacobian of function returning scalar. * Scalar jacobian allowed if *n==1 */ if(isReal(sexp_fjac) && IS_SCALAR(sexp_fjac,REALSXP) && *n == 1 ) ; /* test for numerical matrix with correct dimensions */ else if (!isReal(sexp_fjac) || !isMatrix(sexp_fjac) || INTEGER(jdims)[0]!=*n || INTEGER(jdims)[1]!=*n) error("The jacobian function must return a numerical matrix of dimension (%d,%d).",*n,*n); for (j = 0; j < *n; j++) for (i = 0; i < *n; i++) { if( !R_FINITE(REAL(sexp_fjac)[(*n)*j + i]) ) error("non-finite value(s) returned by jacobian (row=%d,col=%d)",i+1,j+1); rjac[(*ldr)*j + i] = REAL(sexp_fjac)[(*n)*j + i]; } UNPROTECT(1); } SEXP nleqslv(SEXP xstart, SEXP fn, SEXP jac, SEXP rmethod, SEXP rglobal, SEXP rxscalm, SEXP rjacobian, SEXP control, SEXP rho) { double *x, *rwork, *rcdwrk, *qrwork, *rjac; double *xp, *fp, *gp, *scalex; double *pjac; int *icdwrk; const char *z; SEXP eval_test; SEXP sexp_x, sexp_diag, sexp_fvec, sexp_info, sexp_message, sexp_nfcnt, sexp_njcnt, sexp_iter; SEXP sexp_jac; SEXP out, out_names; SEXP xnames; char message[256]; int i, j, n, njcnt, nfcnt, iter, termcd, lrwork, qrwsiz, lrjac, ldr; int maxit, method, global, xscalm; int jactype, jacflg[4], dsub, dsuper; int outopt[3]; double xtol, ftol, btol, stepmx, delta, sigma, cndtol; if( activeflag ) error("Recursive call of nleqslv not possible"); ++activeflag; OS = (OptStruct) R_alloc(1, sizeof(opt_struct)); if( isReal(xstart) ) PROTECT(OS->x = duplicate(xstart)); else if(isInteger(xstart) || isLogical(xstart) ) PROTECT(OS->x = coerceVector(xstart,REALSXP)); else error("Argument 'x' cannot be converted to numeric!"); OS->names = getAttrib(xstart, R_NamesSymbol); /* paranoid check */ n = length(OS->x); if( n < 1 ) error("(Internal) length OS->x should be >= 1"); for (i = 0; i < n; i++) if( !R_FINITE(REAL(OS->x)[i]) ) error("'x' contains a non-finite value at index=%d\n",i+1); if (!isFunction(fn)) error("fn is not a function!"); PROTECT(OS->fcall = lang2(fn, OS->x)); if (!isEnvironment(rho)) error("rho is not an environment!"); OS->env = rho; PROTECT(eval_test = eval(OS->fcall, OS->env)); if (!isReal(eval_test)) error("evaluation of fn function returns non-numeric vector!"); i = length(eval_test); if( i != n ) error("Length of fn result <> length of x!"); for (i = 0; i < n; i++) if( !R_FINITE(REAL(eval_test)[i]) ) error("initial value of fn function contains non-finite values (starting at index=%d)\n" " Check initial x and/or correctness of function",i+1); UNPROTECT(1); z = CHAR(STRING_ELT(rmethod, 0)); if( strcmp(z,"Broyden") == 0 ) method = 1; else method = 0; xtol = asReal(getListElement(control, "xtol")); ftol = asReal(getListElement(control, "ftol")); btol = asReal(getListElement(control, "btol")); sigma = asReal(getListElement(control, "sigma")); stepmx = asReal(getListElement(control, "stepmax")); delta = asReal(getListElement(control, "delta")); cndtol = asReal(getListElement(control, "cndtol")); if(!R_FINITE(xtol)) error("'xtol' is not a valid finite number"); if(!R_FINITE(ftol)) error("'ftol' is not a valid finite number"); if(!R_FINITE(btol)) error("'btol' is not a valid finite number"); if(!R_FINITE(sigma)) error("'sigma' is not a valid finite number"); if(!R_FINITE(stepmx)) error("'stepmax' is not a valid finite number"); if(!R_FINITE(delta)) error("'delta' is not a valid finite number"); if(!R_FINITE(cndtol)) error("'cndtol' is not a valid finite number"); maxit = asInteger(getListElement(control, "maxit")); if(maxit == NA_INTEGER) error("'maxit' is not an integer"); outopt[0] = asInteger(getListElement(control, "trace")); outopt[1] = asLogical(getListElement(control, "chkjac")); outopt[2] = asLogical(rjacobian) ? 1 : 0; z = CHAR(STRING_ELT(rglobal, 0)); if( strcmp(z,"none") == 0 ) global = 0; else if( strcmp(z,"cline") == 0 ) global = 1; else if( strcmp(z,"qline") == 0 ) global = 2; else if( strcmp(z,"gline") == 0 ) global = 3; else if( strcmp(z,"dbldog") == 0 ) global = 4; else if( strcmp(z,"pwldog") == 0 ) global = 5; else if( strcmp(z,"hook") == 0 ) global = 6; z = CHAR(STRING_ELT(rxscalm, 0)); if( strcmp(z,"fixed") == 0 ) xscalm = 0; else xscalm = 1; dsub = asInteger(getListElement(control, "dsub")); dsuper = asInteger(getListElement(control, "dsuper")); /* -1 means not specified i.e. not active */ if(dsub == NA_INTEGER || dsub < -1 || dsub > n-2) error("Invalid/impossible value for 'dsub'"); if(dsuper == NA_INTEGER || dsuper < -1 || dsuper > n-2) error("Invalid/impossible value for 'dsuper'"); if( (dsub < 0 && dsuper >= 0) || (dsuper < 0 && dsub >= 0) ) error("Both dsub and dsuper must be specified"); if(method == 1 && dsub == 0 && dsuper == 0) error("method Broyden not implemented for dsub=dsuper=0!"); /* * setup calculation type of jacobian */ jactype = isNull(jac) ? 0 : 1; if( dsub >= 0 && dsuper >= 0 ) { /* * both dsub and dsuper specified and >= 0 * banded jacobian */ jactype += 2; jacflg[1] = OS->dsub = dsub; jacflg[2] = OS->dsuper = dsuper; } else { jacflg[1] = OS->dsub = -1; jacflg[2] = OS->dsuper = -1; } jacflg[0] = jactype; /* for adjusting step when singular or illconditioned */ jacflg[3] = asLogical(getListElement(control, "allowSingular")) ? 1 : 0; /* * query the optimal amount of memory Lapack needs * to execute blocked QR code * for largish n (500+) this speeds up significantly */ F77_CALL(liqsiz)(&n, &qrwsiz); if( qrwsiz <= 0 ) error("Error in querying amount of workspace for QR routines\n"); /* * allocate memory for Fortran routines */ qrwork = real_vector(qrwsiz); lrwork = 9*n; ldr = n; /* leading dimension of rjac */ lrjac = method == 1? 2*ldr*n : ldr*n; /* Broyden needs 2*n columns; Newton needs n columns */ x = real_vector(n); xp = real_vector(n); fp = real_vector(n); gp = real_vector(n); scalex = real_vector(n); rwork = real_vector(lrwork); rcdwrk = real_vector(3*n); icdwrk = int_vector(n); rjac = real_vector(lrjac); /* * setup scaling if specified */ /* copied from code in /src/library/stats/src/optim.c */ sexp_diag = getListElement(control, "scalex"); if( LENGTH(sexp_diag) != n ) error("'scalex' is of the wrong length"); PROTECT(sexp_diag = coerceVector(sexp_diag,REALSXP)); for (i = 0; i < n; i++) { scalex[i] = REAL(sexp_diag)[i]; if( !R_FINITE(scalex[i]) ) error("'scalex' contains a non-finite value at index=%d\n",i+1); } /* * initialize initial point */ for (i = 0; i < n; i++) x[i] = REAL(OS->x)[i]; /*========================================================================*/ if( outopt[0] == 1) trace_header(method, global, xscalm, sigma, delta, stepmx, ftol, xtol, btol, cndtol); if( isNull(jac) ) { /* numerical jacobian */ F77_CALL(nwnleq)(x, &n, scalex, &maxit, jacflg, &xtol, &ftol, &btol, &cndtol, &method, &global, &xscalm, &stepmx, &delta, &sigma, rjac, &ldr, rwork, &lrwork, rcdwrk, icdwrk, qrwork, &qrwsiz, FCNJACDUM, &fcnval, outopt, xp, fp, gp, &njcnt, &nfcnt, &iter, &termcd); } else { /* user supplied jacobian */ if (!isFunction(jac)) error("jac is not a function!"); PROTECT(OS->jcall = lang2(jac, OS->x)); F77_CALL(nwnleq)(x, &n, scalex, &maxit, jacflg, &xtol, &ftol, &btol, &cndtol, &method, &global, &xscalm, &stepmx, &delta, &sigma, rjac, &ldr, rwork, &lrwork, rcdwrk, icdwrk, qrwork, &qrwsiz, &fcnjac, &fcnval, outopt, xp, fp, gp, &njcnt, &nfcnt, &iter, &termcd); UNPROTECT(1); } /*========================================================================*/ fcn_message(message, termcd); PROTECT(sexp_x = allocVector(REALSXP,n)); for (i = 0; i < n; i++) REAL(sexp_x)[i] = xp[i]; PROTECT(xnames = getAttrib(xstart,R_NamesSymbol)); if(!isNull(xnames)) setAttrib(sexp_x, R_NamesSymbol, xnames); PROTECT(sexp_fvec = allocVector(REALSXP,n)); for (i = 0; i < n; i++) REAL(sexp_fvec)[i] = fp[i]; PROTECT(sexp_info = allocVector(INTSXP,1)); INTEGER(sexp_info)[0] = termcd; PROTECT(sexp_nfcnt = allocVector(INTSXP,1)); INTEGER(sexp_nfcnt)[0] = nfcnt; PROTECT(sexp_njcnt = allocVector(INTSXP,1)); INTEGER(sexp_njcnt)[0] = njcnt; PROTECT(sexp_iter = allocVector(INTSXP,1)); INTEGER(sexp_iter)[0] = iter; PROTECT(sexp_message = allocVector(STRSXP,1)); SET_STRING_ELT(sexp_message, 0, mkChar(message)); for (i = 0; i < n; i++) REAL(sexp_diag)[i] = scalex[i]; if( outopt[2] == 1 ) PROTECT(out = allocVector(VECSXP,9)); else PROTECT(out = allocVector(VECSXP,8)); SET_VECTOR_ELT(out, 0, sexp_x); SET_VECTOR_ELT(out, 1, sexp_fvec); SET_VECTOR_ELT(out, 2, sexp_info); SET_VECTOR_ELT(out, 3, sexp_message); SET_VECTOR_ELT(out, 4, sexp_diag); SET_VECTOR_ELT(out, 5, sexp_nfcnt); SET_VECTOR_ELT(out, 6, sexp_njcnt); SET_VECTOR_ELT(out, 7, sexp_iter); if( outopt[2] == 1 ) { PROTECT(sexp_jac = allocMatrix(REALSXP, n, n)); SET_VECTOR_ELT(out, 8, sexp_jac); pjac = REAL(sexp_jac); for(j=0; j < n; j++) for(i=0; i < n; i++) pjac[j*n+i] = rjac[j*n+i]; if(!isNull(xnames)) { SEXP rcnames; PROTECT(rcnames = allocVector(VECSXP, 2)); SET_VECTOR_ELT(rcnames, 0, duplicate(xnames)); SET_VECTOR_ELT(rcnames, 1, duplicate(xnames)); setAttrib(sexp_jac, R_DimNamesSymbol, rcnames); UNPROTECT(1); } } if( outopt[2] == 1 ) PROTECT(out_names = allocVector(STRSXP,9)); else PROTECT(out_names = allocVector(STRSXP,8)); SET_STRING_ELT(out_names, 0, mkChar("x")); SET_STRING_ELT(out_names, 1, mkChar("fvec")); SET_STRING_ELT(out_names, 2, mkChar("termcd")); SET_STRING_ELT(out_names, 3, mkChar("message")); SET_STRING_ELT(out_names, 4, mkChar("scalex")); SET_STRING_ELT(out_names, 5, mkChar("nfcnt")); SET_STRING_ELT(out_names, 6, mkChar("njcnt")); SET_STRING_ELT(out_names, 7, mkChar("iter")); if( outopt[2] == 1 ) SET_STRING_ELT(out_names, 8, mkChar("jac")); setAttrib(out, R_NamesSymbol, out_names); if( outopt[2] == 1 ) UNPROTECT(14); else UNPROTECT(13); return out; } nleqslv/src/nwbjac.f0000644000175100001440000001745713127132302014166 0ustar hornikusers subroutine nwbjac(rjac,r,ldr,n,xc,fc,fq,fvec,fjac,epsm,jacflg, * wrk1,wrk2,wrk3, * xscalm,scalex,gp,cndtol,rcdwrk,icdwrk,dn, * qtf,rcond,qrwork,qrwsiz,njcnt,iter,fstjac,ierr) c----------------------------------------------------------------------- c c Compute Jacobian matrix in xc, fc c scale it, compute gradient in xc and generate QR decomposition c calculate Newton step c c Arguments c c Out rjac Real(ldr,*) jacobian (n columns) and used for storing full Q from Q c Out r Real(ldr,*) used for storing R from QR factorization c In ldr Integer leading dimension of rjac c In n Integer dimensions of problem c In xc Real(*) initial estimate of solution c Inout fc Real(*) function values f(xc) c Wk fq Real(*) workspace c In fjac Name name of routine to calculate jacobian c (optional) c In fvec Name name of routine to calculate f() c In epsm Real machine precision c In jacflg Integer(*) jacobian flag array c jacflg[1]: 0 numeric; 1 user supplied; 2 numerical banded c 3: user supplied banded c jacflg[2]: number of sub diagonals or -1 if not banded c jacflg[3]: number of super diagonals or -1 if not banded c jacflg[4]: 1 if adjusting step allowed when c singular or illconditioned c Wk wrk1 Real(*) workspace c Wk wrk2 Real(*) workspace c Wk wrk3 Real(*) workspace c In xscalm Integer x scaling method c 1 from column norms of first jacobian c increased if needed after first iteration c 0 scaling user supplied c Inout scalex Real(*) scaling factors x(*) c Out gp Real(*) gradient at xp() c In cndtol Real tolerance of test for ill conditioning c Wk rcdwrk Real(*) workspace c Wk icdwrk Integer(*) workspace c Out dn Real(*) Newton step c Out qtf Real(*) workspace for nwnstp c Out rcond Real estimated inverse condition of R from QR c In qrwork Real(*) workspace for Lapack QR routines (call liqsiz) c In qrwsiz Integer size of qrwork c Out njcnt Integer number of jacobian evaluations c In iter Integer iteration counter (used in scaling) c Inout fstjac logical .true. if initial jacobian is available c on exit set to .false. c Out ierr Integer error code c 0 no error c >0 error in nwnstp (singular ...) c c----------------------------------------------------------------------- integer ldr,n,iter, njcnt, ierr integer jacflg(*),xscalm,qrwsiz logical fstjac double precision epsm, cndtol, rcond double precision rjac(ldr,*),r(ldr,*) double precision xc(*),fc(*),dn(*) double precision wrk1(*),wrk2(*),wrk3(*) double precision qtf(*),gp(*),fq(*) double precision scalex(*) double precision rcdwrk(*),qrwork(*) integer icdwrk(*) external fjac,fvec logical stepadj double precision Rzero, Rone parameter(Rzero=0.0d0, Rone=1.0d0) c evaluate the jacobian at the current iterate xc if( .not. fstjac ) then call nwfjac(xc,scalex,fc,fq,n,epsm,jacflg,fvec,fjac,rjac, * ldr,wrk1,wrk2,wrk3) njcnt = njcnt + 1 else fstjac = .false. endif c if requested calculate x scale from jacobian column norms a la Minpack if( xscalm .eq. 1 ) then call vunsc(n,xc,scalex) call nwcpsx(n,rjac,ldr,scalex,epsm,iter) call vscal(n,xc,scalex) endif call nwscjac(n,rjac,ldr,scalex) c evaluate the gradient at the current iterate xc c gp = trans(Rjac) * fc call dgemv('T',n,n,Rone,rjac,ldr,fc,1,Rzero,gp,1) c get broyden (newton) step stepadj = jacflg(4) .eq. 1 call dcopy(n,fc,1,fq,1) call brdstp(rjac,r,ldr,fq,n,cndtol, stepadj, * wrk1,dn,qtf,ierr,rcond, * rcdwrk,icdwrk,qrwork,qrwsiz) c save some data about jacobian for later output call nwsnot(0,ierr,rcond) return end c----------------------------------------------------------------------- subroutine brdstp(rjac,r,ldr,fn,n,cndtol, stepadj, * qraux,dn,qtf,ierr,rcond, * rcdwrk,icdwrk,qrwork,qrwsiz) integer ldr,n,ierr,qrwsiz double precision cndtol,rjac(ldr,*),r(ldr,*),qraux(*),fn(*) double precision dn(*),qtf(*) double precision rcdwrk(*),qrwork(*) integer icdwrk(*) double precision rcond logical stepadj c----------------------------------------------------------------------- c c Calculate the newton step c c Arguments c c Inout rjac Real(ldr,*) jacobian matrix at current iterate; on return full Q c Inout r Real(ldr,*) jacobian matrix at current iterate; on return R fom QR c In ldr Integer leading dimension of rjac c In fn Real(*) function values at current iterate c In n Integer dimension of problem c In cndtol Real tolerance of test for ill conditioning c In stepadj Logical allow adjusting step for singular/illconditioned jacobian c Inout qraux Real(*) QR info from liqrfa (calling Lapack dgeqrf) c Out dn Real(*) Newton direction c Out qtf Real(*) trans(Q)*f() c Out ierr Integer 0 indicating Jacobian not ill-conditioned or singular c 1 indicating Jacobian ill-conditioned c 2 indicating Jacobian completely singular c 3 indicating almost zero LM correction c Out rcond Real inverse condition of upper triangular R of QR c Wk rcdwrk Real(*) workspace c Wk icdwrk Integer(*) workspace c In qrwork Real(*) workspace for Lapack QR routines (call liqsiz) c In qrwsiz Integer size of qrwork c c----------------------------------------------------------------------- integer info double precision Rone parameter(Rone=1.0d0) c perform a QR factorization of rjac (simple Lapack routine) c check for singularity or ill conditioning c form qtf = trans(Q) * fn call liqrfa(rjac,ldr,n,qraux,qrwork,qrwsiz,ierr) c compute qtf = trans(Q)*fn call dcopy(n,fn,1,qtf,1) call liqrqt(rjac, ldr, n, qraux, qtf, qrwork, qrwsiz, info) c copy the upper triangular part of the QR decomposition c contained in Rjac into R[*, 1..n]. c form Q from the QR decomposition (taur/qraux in wrk1) call dlacpy('U',n,n,rjac,ldr,r,ldr) call liqrqq(rjac,ldr,qraux,n,qrwork,qrwsiz,info) c now Rjac[* ,1..n] holds expanded Q c now R[* ,1..n] holds full upper triangle R call lirslv(R,ldr,n,cndtol, stepadj, * qtf,dn,ierr,rcond, rcdwrk,icdwrk) return end nleqslv/src/nwclsh.f0000755000175100001440000001414513127132302014212 0ustar hornikusers subroutine nwclsh(n,xc,fcnorm,d,g,stepmx,xtol,scalex,fvec, * xp,fp,fpnorm,xw,retcd,gcnt,priter,iter) integer n,retcd,gcnt double precision stepmx,xtol,fcnorm,fpnorm double precision xc(*) double precision d(*),g(*),xp(*),fp(*),xw(*) double precision scalex(*) external fvec integer priter,iter c------------------------------------------------------------------------- c c Find a next acceptable iterate using a safeguarded cubic line search c along the newton direction c c Arguments c c In n Integer dimension of problem c In xc Real(*) current iterate c In fcnorm Real 0.5 * || f(xc) ||**2 c In d Real(*) newton direction c In g Real(*) gradient at current iterate c In stepmx Real maximum stepsize c In xtol Real relative step size at which c successive iterates are considered c close enough to terminate algorithm c In scalex Real(*) diagonal scaling matrix for x() c In fvec Name name of routine to calculate f() c In xp Real(*) new x() c In fp Real(*) new f(x) c In fpnorm Real .5*||fp||**2 c Out xw Real(*) workspace for unscaling x(*) c c Out retcd Integer return code c 0 new satisfactory x() found c 1 no satisfactory x() found c sufficiently distinct from xc() c c Out gcnt Integer number of steps taken c In priter Integer >0 unit if intermediate steps to be printed c -1 if no printing c c------------------------------------------------------------------------- integer i double precision alpha,slope,rsclen,oarg(4) double precision lambda,lamhi,lamlo,t double precision ddot,dnrm2, nudnrm, ftarg double precision dlen double precision a, b, disc, fpt, fpt0, fpnorm0, lambda0 integer idamax logical firstback parameter (alpha = 1.0d-4) double precision Rhalf, Rone, Rtwo, Rthree, Rten, Rzero parameter(Rzero=0.0d0) parameter(Rhalf=0.5d0, Rone=1.0d0, Rtwo=2.0d0, Rten=10.0d0) parameter(Rthree=3.0d0) double precision t1,t2 double precision dlamch c silence warnings issued by ftncheck lambda0 = Rzero fpnorm0 = Rzero c safeguard initial step size dlen = dnrm2(n,d,1) if( dlen .gt. stepmx ) then lamhi = stepmx / dlen else lamhi = Rone endif c compute slope = g-trans * d slope = ddot(n,g,1,d,1) c compute the smallest value allowable for the damping c parameter lambda ==> lamlo rsclen = nudnrm(n,d,xc) lamlo = xtol / rsclen c initialization of retcd and lambda (linesearch length) retcd = 2 lambda = lamhi gcnt = 0 firstback = .true. do while( retcd .eq. 2 ) c compute next x do i=1,n xp(i) = xc(i) + lambda*d(i) enddo c evaluate functions and the objective function at xp call nwfvec(xp,n,scalex,fvec,fp,fpnorm,xw) gcnt = gcnt + 1 ftarg = fcnorm + alpha * lambda * slope if( priter .gt. 0) then oarg(1) = lambda oarg(2) = ftarg oarg(3) = fpnorm oarg(4) = abs(fp(idamax(n,fp,1))) call nwlsot(iter,1,oarg) endif c first is quadratic c test whether the standard step produces enough decrease c of the objective function. c If not update lambda and compute a new next iterate if( fpnorm .le. ftarg ) then retcd = 0 else if( fpnorm .gt. lamlo**2 * sqrt(dlamch('O')) ) then c safety against overflow in what follows (use lamlo**2 for safety) lambda = lambda/Rten firstback = .true. else if( firstback ) then t = ((-lambda**2)*slope/Rtwo)/ * (fpnorm-fcnorm-lambda*slope) firstback = .false. else fpt = fpnorm -fcnorm - lambda*slope fpt0 = fpnorm0-fcnorm - lambda0*slope a = fpt/lambda**2 - fpt0/lambda0**2 b = -lambda0*fpt/lambda**2 + lambda*fpt0/lambda0**2 a = a /(lambda - lambda0) b = b /(lambda - lambda0) if( abs(a) .le. dlamch('E') ) then c not quadratic but linear t = -slope/(2*b) else c use Higham procedure to compute roots acccurately c Higham: Accuracy and Stability of Numerical Algorithms, second edition,2002, page 10. c Actually solving 3*a*x^2+2*b*x+c=0 ==> (3/2)*a*x^2+b*x+(c/2)=0 c use max to prevent NaN in sqrt(disc) disc = max(b**2 - Rthree * a * slope,Rzero) t1 = -(b+sign(Rone,b)*sqrt(disc))/(Rthree*a) t2 = slope/(Rthree*a)/t1 if(a .gt. Rzero ) then c upward opening parabola ==> rightmost is solution t = max(t1,t2) else c downward opening parabola ==> leftmost is solution t = min(t1,t2) endif endif t = min(t, Rhalf*lambda) endif lambda0 = lambda fpnorm0 = fpnorm lambda = max(t,lambda/Rten) if(lambda .lt. lamlo) then retcd = 1 endif endif endif enddo return end nleqslv/src/nwddlg.f0000755000175100001440000002004713127132302014171 0ustar hornikusers subroutine nwddlg(n,rjac,ldr,dn,g,xc,fcnorm,stepmx,xtol, * delta,qtf,scalex,fvec,d,xprev, * ssd,v,wa,fprev,xp,fp,fpnorm,retcd,gcnt, * priter,iter) integer ldr, n, retcd, gcnt, priter, iter double precision fcnorm, stepmx, xtol, fpnorm, delta double precision rjac(ldr,*), dn(*), g(*), xc(*), qtf(*) double precision scalex(*), d(*) double precision xprev(*), xp(*), fp(*) double precision ssd(*), v(*), wa(*), fprev(*) external fvec c------------------------------------------------------------------------- c c Find a next iterate xp by the double dogleg method c c Arguments c c In n Integer size of problem: dimension x, f c In Rjac Real(ldr,*) R of QR-factored jacobian c In ldr Integer leading dimension of Rjac c Inout dn Real(*) newton direction c Inout g Real(*) gradient at current point c trans(jac)*f() c In xc Real(*) current iterate c In fcnorm Real .5*||f(xc)||**2 c In stepmx Real maximum stepsize c In xtol Real x-tolerance (stepsize) c Inout delta Real on input: initial trust region radius c if -1 then set to something c reasonable c on output: final value c ! Do not modify between calls while c still iterating c In qtf Real(*) trans(Q)*f(xc) c In scalex Real(*) scaling factors for x() c In fvec Name name of subroutine to evaluate f(x) c ! must be declared external in caller c Wk d Real(*) work vector c Wk xprev Real(*) work vector c Wk ssd Real(*) work vector c Wk v Real(*) work vector c Wk wa Real(*) work vector c Wk fprev Real(*) work vector c Out xp Real(*) new x() c Out fp Real(*) new f(xp) c Out fpnorm Real new .5*||f(xp)||**2 c Out retcd Integer return code c 0 new satisfactory x() found c 1 no satisfactory x() found c Out gcnt Integer number of steps taken c In priter Integer print flag c -1 no intermediate printing c >0 yes for print of intermediate results c In iter Integer current iteration (only used for above) c c All vectors at least size n c c------------------------------------------------------------------------- integer i double precision dnlen,ssdlen,alpha,beta,lambda,fpred double precision sqalpha,eta,gamma,fpnsav,oarg(7) double precision dnrm2,ddot logical nwtstep integer dtype integer idamax double precision Rone, Rtwo, Rten, Rhalf, Rp2, Rp8 parameter(Rhalf=0.5d0) parameter(Rone=1.0d0, Rtwo=2.0d0, Rten=10.0d0) parameter(Rp2 = Rtwo/Rten, Rp8 = Rone - Rp2) double precision Rzero parameter(Rzero=0.0d0) c length newton direction dnlen = dnrm2(n, dn, 1) c steepest descent direction and length sqalpha = dnrm2(n,g,1) alpha = sqalpha**2 call dcopy(n, g, 1, d, 1) call dtrmv('U','N','N',n,rjac,ldr,d,1) beta = dnrm2(n,d,1)**2 call dcopy(n, g, 1, ssd, 1) call dscal(n, -(alpha/beta), ssd, 1) ssdlen = alpha*sqalpha/beta c set trust radius to ssdlen or dnlen if required if( delta .eq. -Rone ) then delta = min(ssdlen, stepmx) elseif( delta .eq. -Rtwo ) then delta = min(dnlen, stepmx) endif c calculate double dogleg parameter gamma = alpha*alpha/(-beta*ddot(n,g,1,dn,1)) c call dgdbg(gamma, alpha*alpha, -beta*ddot(n,g,1,dn,1)) c precautionary (just in case) eta = max(Rzero, min(Rone,Rp2 + Rp8*gamma)) retcd = 4 gcnt = 0 do while( retcd .gt. 1 ) c find new step by double dogleg algorithm call ddlgstp(n,dn,dnlen,delta,v, * ssd,ssdlen,eta,d,dtype,lambda) nwtstep = dtype .eq. 4 c compute the model prediction 0.5*||F + J*d||**2 (L2-norm) call dcopy(n,d,1,wa,1) call dtrmv('U','N','N',n,rjac,ldr,wa,1) call daxpy(n, Rone, qtf,1,wa,1) fpred = Rhalf * dnrm2(n,wa,1)**2 c evaluate function at xp = xc + d do i=1,n xp(i) = xc(i) + d(i) enddo call nwfvec(xp,n,scalex,fvec,fp,fpnorm,wa) gcnt = gcnt + 1 c check whether the global step is acceptable oarg(2) = delta call nwtrup(n,fcnorm,g,d,nwtstep,stepmx,xtol,delta, * fpred,retcd,xprev,fpnsav,fprev,xp,fp,fpnorm) if( priter .gt. 0 ) then oarg(1) = lambda oarg(3) = delta oarg(4) = eta oarg(5) = fpnorm oarg(6) = abs(fp(idamax(n,fp,1))) call nwdgot(iter,dtype,retcd,oarg) endif enddo return end c----------------------------------------------------------------------- subroutine ddlgstp(n,dn,dnlen,delta,v, * ssd,ssdlen,eta,d,dtype,lambda) integer n double precision dn(*), ssd(*), v(*), d(*) double precision dnlen, delta, ssdlen, eta, lambda integer dtype c------------------------------------------------------------------------- c c Find a new step by the double dogleg algorithm c Internal routine for nwddlg c c Arguments c c In n Integer size of problem c In dn Real(*) current newton step c Out dnlen Real length dn() c In delta Real current trust region radius c Out v Real(*) (internal) eta * dn() - ssd() c In ssd Real(*) (internal) steepest descent direction c In ssdlen Real (internal) length ssd c In eta Real (internal) double dogleg parameter c Out d Real(*) new step for x() c Out dtype Integer steptype c 1 steepest descent c 2 combination of dn and ssd c 3 partial newton step c 4 full newton direction c Out lambda Real weight of eta*dn() in d() c closer to 1 ==> more of eta*dn() c c----------------------------------------------------------------------- integer i double precision vssd, vlen double precision dnrm2, ddot if(dnlen .le. delta) then c Newton step smaller than trust radius ==> take it call dcopy(n, dn, 1, d, 1) delta = dnlen dtype = 4 elseif(eta*dnlen .le. delta) then c take partial step in newton direction call dcopy(n, dn, 1, d, 1) call dscal(n, delta / dnlen, d, 1) dtype = 3 elseif(ssdlen .ge. delta) then c take step in steepest descent direction call dcopy(n, ssd, 1, d, 1) call dscal(n, delta / ssdlen, d, 1) dtype = 1 else c calculate convex combination of ssd and eta*dn with length delta do i=1,n v(i) = eta*dn(i) - ssd(i) enddo vssd = ddot(n,v,1,ssd,1) vlen = dnrm2(n,v,1)**2 lambda =(-vssd+sqrt(vssd**2-vlen*(ssdlen**2-delta**2)))/vlen call dcopy(n, ssd, 1, d, 1) call daxpy(n, lambda, v, 1, d, 1) dtype = 2 endif return end nleqslv/src/nwmhlm.f0000755000175100001440000001625513127132302014222 0ustar hornikusers subroutine nwmhlm(n,rjac,ldr,dn,g,xc,fcnorm,stepmx,xtol, * delta,qtf,scalex,fvec,d,xprev, * ssd,v,wa,fprev,xp,fp,fpnorm,retcd,gcnt, * priter,iter) integer ldr, n, retcd, gcnt, priter, iter double precision fcnorm, stepmx, xtol, fpnorm, delta double precision rjac(ldr,*), dn(*), g(*), xc(*), qtf(*) double precision scalex(*), d(*) double precision xprev(*), xp(*), fp(*) double precision ssd(*), v(*), wa(*), fprev(*) external fvec c------------------------------------------------------------------------- c c Find a next iterate xp by the More-Hebden-Levenberg-Marquardt method c c Arguments c c In n Integer size of problem: dimension x, f c In Rjac Real(ldr,*) R of QR-factored jacobian c In ldr Integer leading dimension of Rjac c Inout dn Real(*) newton direction c Inout g Real(*) gradient at current point c trans(jac)*f() c In xc Real(*) current iterate c In fcnorm Real .5*||f(xc)||**2 c In stepmx Real maximum stepsize c In xtol Real x-tolerance (stepsize) c Inout delta Real on input: initial trust region radius c if -1 then set to something c reasonable c on output: final value c ! Do not modify between calls while c still iterating c In qtf Real(*) trans(Q)*f(xc) c In scalex Real(*) scaling factors for x() c In fvec Name name of subroutine to evaluate f(x) c ! must be declared external in caller c Wk d Real(*) work vector c Wk xprev Real(*) work vector c Wk ssd Real(*) work vector c Wk v Real(*) work vector c Wk wa Real(*) work vector c Wk fprev Real(*) work vector c Out xp Real(*) new x() c Out fp Real(*) new f(xp) c Out fpnorm Real new .5*||f(xp)||**2 c Out retcd Integer return code c 0 new satisfactory x() found c 1 no satisfactory x() found c Out gcnt Integer number of steps taken c In priter Integer print flag c -1 no intermediate printing c >0 yes for print of intermediate results c In iter Integer current iteration (only used for above) c c All vectors at least size n c c------------------------------------------------------------------------- integer i double precision dnlen,glen,ssdlen,alpha,beta,mu,fpred double precision fpnsav,oarg(6) double precision dnrm2 logical nwtstep integer dtype integer idamax double precision Rone, Rtwo, Rhalf parameter(Rhalf=0.5d0) parameter(Rone=1.0d0, Rtwo=2.0d0) c length newton direction dnlen = dnrm2(n, dn, 1) c gradient length and steepest descent direction and length glen = dnrm2(n,g,1) alpha = glen**2 call dcopy(n, g, 1, d, 1) call dtrmv('U','N','N',n,rjac,ldr,d,1) beta = dnrm2(n,d,1)**2 call dcopy(n, g, 1, ssd, 1) call dscal(n, -(alpha/beta), ssd, 1) ssdlen = alpha*glen/beta c set trust radius to ssdlen or dnlen if required if( delta .eq. -Rone ) then delta = min(ssdlen, stepmx) elseif( delta .eq. -Rtwo ) then delta = min(dnlen, stepmx) endif retcd = 4 gcnt = 0 do while( retcd .gt. 1 ) c find new step by More Hebden LM algorithm c reuse ssd as sdiag call nwmhstep(Rjac,ldr,n,ssd,qtf,dn,dnlen,glen,delta,mu, * d, v, dtype) nwtstep = dtype .eq. 2 c compute the model prediction 0.5*||F + J*d||**2 (L2-norm) call dcopy(n,d,1,wa,1) call dtrmv('U','N','N',n,rjac,ldr,wa,1) call daxpy(n, Rone, qtf,1,wa,1) fpred = Rhalf * dnrm2(n,wa,1)**2 c evaluate function at xp = xc + d do i=1,n xp(i) = xc(i) + d(i) enddo call nwfvec(xp,n,scalex,fvec,fp,fpnorm,wa) gcnt = gcnt + 1 c check whether the global step is acceptable oarg(2) = delta call nwtrup(n,fcnorm,g,d,nwtstep,stepmx,xtol,delta, * fpred,retcd,xprev,fpnsav,fprev,xp,fp,fpnorm) if( priter .gt. 0 ) then oarg(1) = mu oarg(3) = delta oarg(4) = dnrm2(n, d, 1) oarg(5) = fpnorm oarg(6) = abs(fp(idamax(n,fp,1))) call nwmhot(iter,dtype,retcd,oarg) endif enddo return end c----------------------------------------------------------------------- subroutine nwmhstep(R,ldr,n,sdiag,qtf,dn,dnlen,glen,delta,mu, * d, work, dtype) integer ldr, n double precision R(ldr,*) double precision sdiag(*), qtf(*), dn(*), d(*), work(*) double precision dnlen, glen, delta, mu integer dtype c------------------------------------------------------------------------- c c Find a new step by the More Hebden Levemberg Marquardt algorithm c Internal routine for nwmhlm c c Arguments c c In R Real(ldr,*) R of QR-factored jacobian c In ldr Integer leading dimension of R c In n Integer size of problem c Out sdiag Real(*) diagonal of LM lower triangular modified R c In qtf Real(*) trans(Q)*f(xc) c In dn Real(*) current newton step c Out dnlen Real length dn() c In glen Real length gradient c In delta Real current trust region radius c Inout mu Real Levenberg-Marquardt parameter c Out d Real(*) new step for x() c Work work Real(*) work vector for limhpar c Out dtype Integer steptype c 1 LM step c 2 full newton direction c c----------------------------------------------------------------------- double precision Rone parameter(Rone=1.0D0) if(dnlen .le. delta) then c Newton step smaller than trust radius ==> take it call dcopy(n, dn, 1, d, 1) delta = dnlen dtype = 2 else c calculate LM step call limhpar(R, ldr, n, sdiag, qtf, dn, dnlen, glen, delta, * mu, d, work) c change sign of step d (limhpar solves for trans(R)*R+mu*I)=qtf instead of -qtf) call dscal(n,-Rone,d,1) dtype = 1 endif return end nleqslv/src/liqrup.f0000644000175100001440000000463013127132302014223 0ustar hornikusers subroutine liqrup(Q,ldq,n,R,ldr,u,v,wk) integer ldq,n,ldr double precision Q(ldq,*),R(ldr,*),u(*),v(*),wk(*) c----------------------------------------------------------------------------- c c Arguments c c Inout Q Real(ldq,n) orthogonal matrix from QR c In ldq Integer leading dimension of Q c In n Integer order of Q and R c Inout R Real(ldr,n) upper triangular matrix R from QR c In ldr Integer leading dimension of R c In u Real(*) vector u of size n c In v Real(*) vector v of size n c Out wk Real(*) workspace of size n c c on return c c Q Q is the matrix with orthonormal columns in a QR c decomposition of the matrix B = A + u*v' c c R R is the upper triangular matrix in a QR c decomposition of the matrix B = A + u*v' c c Description c c The matrices Q and R are a QR decomposition of a square matrix c A = Q*R. c Given Q and R, qrupdt computes a QR decomposition of the rank one c modification B = A + u*trans(v) of A. Here u and v are vectors. c c Code based on Reichel and Cragg and simplified and modernized c Reichel, L. and W.B. Gragg (1990), Algorithm 686: FORTRAN subroutines for updating the QR decomposition, c ACM Trans. Math. Softw., 16, 4, pp. 369--377. c c----------------------------------------------------------------------------- c Local variables and functions integer k,i double precision ddot, c, s c calculate wk = trans(Q)*u do i=1,n wk(i) = ddot(n,Q(1,i),1,u,1) enddo c nuvgiv uses Lapack dlartg and c sets its first argument x to value of the last argument returned by dlartg. c zero components wk(n),wk(n-1)...wk(2) c and apply rotators to R and Q. do k=n-1,1,-1 call nuvgiv(wk(k),wk(k+1),c,s) call drot(n-k+1,R(k,k),ldr,R(k+1,k),ldr,c,s) call drot(n ,Q(1,k),1 ,Q(1,k+1),1 ,c,s) enddo c r(1,1:n) += wk(1)*v(1:n) call daxpy(n,wk(1),v,1,R(1,1),ldr) c R is of upper hessenberg form. Triangularize R. do k=1,n-1 call nuvgiv(R(k,k),R(k+1,k),c,s) call drot(n-k,R(k,k+1),ldr,R(k+1,k+1),ldr,c,s) call drot(n ,Q(1,k) ,1 ,Q(1,k+1) ,1 ,c,s) enddo return end nleqslv/src/nwnjac.f0000644000175100001440000001642613127132302014175 0ustar hornikusers subroutine nwnjac(rjac,ldr,n,xc,fc,fq,fvec,fjac,epsm,jacflg, * wrk1,wrk2,wrk3, * xscalm,scalex,gp,cndtol,rcdwrk,icdwrk,dn, * qtf,rcond,qrwork,qrwsiz,njcnt,iter,fstjac,ierr) c----------------------------------------------------------------------- c c Compute Jacobian matrix in xc, fc c scale it, compute gradient in xc and generate QR decomposition c calculate Newton step c c Arguments c c Out rjac Real(ldr,*) jacobian (n columns) c In ldr Integer leading dimension of rjac c In n Integer dimensions of problem c In xc Real(*) initial estimate of solution c Inout fc Real(*) function values f(xc) c Wk fq Real(*) workspace c In fjac Name name of routine to calculate jacobian c (optional) c In fvec Name name of routine to calculate f() c In epsm Real machine precision c In jacflg Integer(*) jacobian flag array c jacflg[1]: 0 numeric; 1 user supplied; 2 numerical banded c 3: user supplied banded c jacflg[2]: number of sub diagonals or -1 if not banded c jacflg[3]: number of super diagonals or -1 if not banded c jacflg[4]: 1 if adjusting step allowed when c singular or illconditioned c Wk wrk1 Real(*) workspace c Wk wrk2 Real(*) workspace c Wk wrk3 Real(*) workspace c In xscalm Integer x scaling method c 1 from column norms of first jacobian c increased if needed after first iteration c 0 scaling user supplied c Inout scalex Real(*) scaling factors x(*) c Out gp Real(*) gradient at xp() c In cndtol Real tolerance of test for ill conditioning c Wk rcdwrk Real(*) workspace c Wk icdwrk Integer(*) workspace c Out dn Real(*) Newton step c Out qtf Real(*) workspace for nwnstp c Out rcond Real estimated inverse condition of R from QR c In qrwork Real(*) workspace for Lapack QR routines (call liqsiz) c In qrwsiz Integer size of qrwork c Out njcnt Integer number of jacobian evaluations c In iter Integer iteration counter (used in scaling) c Inout fstjac logical .true. if initial jacobian is available c on exit set to .false. c Out ierr Integer error code c 0 no error c >0 error in nwnstp (singular ...) c c----------------------------------------------------------------------- integer ldr,n,iter, njcnt, ierr integer jacflg(*),xscalm,qrwsiz logical fstjac double precision epsm, cndtol, rcond double precision rjac(ldr,*) double precision xc(*),fc(*),dn(*) double precision wrk1(*),wrk2(*),wrk3(*) double precision qtf(*),gp(*),fq(*) double precision scalex(*) double precision rcdwrk(*),qrwork(*) integer icdwrk(*) external fjac,fvec logical stepadj double precision Rzero, Rone parameter(Rzero=0.0d0, Rone=1.0d0) c evaluate the jacobian at the current iterate xc if( .not. fstjac ) then call nwfjac(xc,scalex,fc,fq,n,epsm,jacflg,fvec,fjac,rjac, * ldr,wrk1,wrk2,wrk3) njcnt = njcnt + 1 else fstjac = .false. endif c if requested calculate x scale from jacobian column norms a la Minpack if( xscalm .eq. 1 ) then call vunsc(n,xc,scalex) call nwcpsx(n,rjac,ldr,scalex,epsm,iter) call vscal(n,xc,scalex) endif call nwscjac(n,rjac,ldr,scalex) c evaluate the gradient at the current iterate xc c gp = trans(Rjac) * fc call dgemv('T',n,n,Rone,rjac,ldr,fc,1,Rzero,gp,1) c get newton step stepadj = jacflg(4) .eq. 1 call dcopy(n,fc,1,fq,1) call nwnstp(rjac,ldr,fq,n,cndtol, stepadj, * wrk1,dn,qtf,ierr,rcond, * rcdwrk,icdwrk,qrwork,qrwsiz) c save some data about jacobian for later output call nwsnot(0,ierr,rcond) return end c----------------------------------------------------------------------- subroutine nwnstp(rjac,ldr,fn,n,cndtol, stepadj, * qraux,dn,qtf,ierr,rcond, * rcdwrk,icdwrk,qrwork,qrwsiz) integer ldr,n,ierr,qrwsiz double precision cndtol,rjac(ldr,*),qraux(*),fn(*) double precision dn(*),qtf(*) double precision rcdwrk(*),qrwork(*) integer icdwrk(*) double precision rcond logical stepadj c----------------------------------------------------------------------- c c Calculate the newton step c c Arguments c c Inout rjac Real(ldr,*) jacobian matrix at current iterate c overwritten with QR decomposition c In ldr Integer leading dimension of rjac c In fn Real(*) function values at current iterate c In n Integer dimension of problem c In cndtol Real tolerance of test for ill conditioning c In stepadj Logical allow adjusting step for singular/illconditioned jacobian c Inout qraux Real(*) QR info from liqrfa (calling Lapack dgeqrf) c Out dn Real(*) Newton direction c Out qtf Real(*) trans(Q)*f() c Out ierr Integer 0 indicating Jacobian not ill-conditioned or singular c 1 indicating Jacobian ill-conditioned c 2 indicating Jacobian completely singular c 3 indicating almost zero LM correction c Out rcond Real inverse condition of upper triangular R of QR c Wk rcdwrk Real(*) workspace c Wk icdwrk Integer(*) workspace c In qrwork Real(*) workspace for Lapack QR routines (call liqsiz) c In qrwsiz Integer size of qrwork c c----------------------------------------------------------------------- integer info double precision Rone parameter(Rone=1.0d0) c perform a QR factorization of rjac (simple Lapack routine) c check for singularity or ill conditioning c form qtf = trans(Q) * fn call liqrfa(Rjac,ldr,n,qraux,qrwork,qrwsiz,ierr) c compute qtf = trans(Q)*fn call dcopy(n,fn,1,qtf,1) call liqrqt(Rjac, ldr, n, qraux, qtf, qrwork, qrwsiz, info) call lirslv(Rjac,ldr,n,cndtol, stepadj, * qtf,dn,ierr,rcond, rcdwrk,icdwrk) return end nleqslv/src/nwutil.f0000755000175100001440000007625213127132302014245 0ustar hornikusers subroutine nwtcvg(xplus,fplus,xc,xtol,retcd,ftol,iter, * maxit,n,ierr,termcd) integer n,iter,maxit,ierr,termcd,retcd double precision xtol,ftol double precision xplus(*),fplus(*),xc(*) c------------------------------------------------------------------------- c c Decide whether to terminate the nonlinear algorithm c c Arguments c c In xplus Real(*) new x values c In fplus Real(*) new f values c In xc Real(*) current x values c In xtol Real stepsize tolerance c In retcd Integer return code from global search routines c In ftol Real function tolerance c In iter Integer iteration number c In maxit Integer maximum number of iterations allowed c In n Integer size of x and f c In ierr Integer return code of cndjac (condition estimation) c c Out termcd Integer termination code c 0 no termination criterion satisfied c ==> continue iterating c 1 norm of scaled function value is c less than ftol c 2 scaled distance between last c two steps less than xtol c 3 unsuccessful global strategy c ==> cannot find a better point c 4 iteration limit exceeded c 5 Jacobian too ill-conditioned c 6 Jacobian singular c 7 Jacobian not usable (all zero entries) c c------------------------------------------------------------------------- double precision fmax,rsx, nuxnrm integer idamax c check whether function values are within tolerance termcd = 0 if( ierr .ne. 0 ) then termcd = 4 + ierr return endif fmax = abs(fplus(idamax(n,fplus,1))) if( fmax .le. ftol) then termcd = 1 return endif c initial check at start so there is no xplus c so only a check of function values is useful if(iter .eq. 0) return if(retcd .eq. 1) then termcd = 3 return endif c check whether relative step length is within tolerance c Dennis Schnabel Algorithm A7.2.3 rsx = nuxnrm(n, xplus, xc) if(rsx .le. xtol) then termcd = 2 return endif c check iteration limit if(iter .ge. maxit) then termcd = 4 endif return end c----------------------------------------------------------------------- subroutine nweset(n,xc,fc,fcnorm,xp,fp,fpnorm,gcnt,priter,iter) double precision xc(*),fc(*),fcnorm,xp(*),fp(*),fpnorm integer n, gcnt, priter, iter c------------------------------------------------------------------------- c c calling routine got an error in decomposition/update of Jacobian/Broyden c jacobian an singular or too ill-conditioned c prepare return arguments c c Arguments c c In n Integer size of x c In xc Real(*) current (starting) x values c In fc Real(*) function values f(xc) c In fcnorm Real norm fc c Out xp Real(*) final x values c Out fp Real(*) function values f(xp) c Out fpnorm Real final norm fp c Out gcnt Integer # of backtracking steps (here set to 0) c In priter Integer flag for type of output c In iter Integer iteration counter c c------------------------------------------------------------------------- call dcopy(n,xc,1,xp,1) call dcopy(n,fc,1,fp,1) fpnorm = fcnorm gcnt = 0 if( priter .gt. 0 ) then call nwjerr(iter) endif return end c----------------------------------------------------------------------- subroutine chkjac1(A,lda,xc,fc,n,epsm,scalex,fz,wa,xw,fvec,termcd) integer lda,n,termcd double precision A(lda,*),xc(*),fc(*) double precision epsm,scalex(*) double precision fz(*),wa(*),xw(*) external fvec c------------------------------------------------------------------------- c c Check the user supplied jacobian against its finite difference approximation c c Arguments c c In A Real(lda,*) user supplied jacobian c In lda Integer leading dimension of ajanal c In xc Real(*) vector of x values c In fc Real(*) function values f(xc) c In n Integer size of x c In epsm Real machine precision c In scalex Real(*) scaling vector for x() c Wk fz Real(*) workspace c Wk wa Real(*) workspace c Wk xw Real(*) workspace c In fvec Name name of routine to evaluate f(x) c Out termcd Integer return code c 0 user supplied jacobian ok c -10 user supplied jacobian NOT ok c c------------------------------------------------------------------------- integer i,j,errcnt double precision ndigit,p,h,xcj,dinf double precision tol double precision rnudif integer idamax integer MAXERR parameter(MAXERR=10) double precision Rquart, Rten parameter(Rquart=0.25d0, Rten=10.0d0) termcd = 0 c compute the finite difference jacobian and check it against c the analytic one ndigit = -log10(epsm) p = sqrt(max(Rten**(-ndigit),epsm)) tol = epsm**Rquart errcnt = 0 call dcopy(n,xc,1,xw,1) call vunsc(n,xw,scalex) do j=1,n h = p + p * abs(xw(j)) xcj = xw(j) xw(j) = xcj + h c avoid (small) rounding errors c h = xc(j) - xcj but not here to avoid clever optimizers h = rnudif(xw(j), xcj) call fvec(xw,fz,n,j) xw(j) = xcj do i=1,n wa(i) = (fz(i)-fc(i))/h enddo dinf = abs(wa(idamax(n,wa,1))) do i=1,n if(abs(A(i,j)-wa(i)).gt.tol*dinf) then errcnt = errcnt + 1 if( errcnt .gt. MAXERR ) then termcd = -10 return endif call nwckot(i,j,A(i,j),wa(i)) endif enddo enddo c call vscal(n,xc,scalex) if( errcnt .gt. 0 ) then termcd = -10 endif return end c----------------------------------------------------------------------- subroutine chkjac2(A,lda,xc,fc,n,epsm,scalex,fz,wa,xw,fvec,termcd, * dsub,dsuper) integer lda,n,termcd,dsub,dsuper double precision A(lda,*),xc(*),fc(*) double precision epsm,scalex(*) double precision fz(*),wa(*),xw(*) external fvec c------------------------------------------------------------------------- c c Check the user supplied jacobian against its finite difference approximation c c Arguments c c In A Real(lda,*) user supplied jacobian c In lda Integer leading dimension of ajanal c In xc Real(*) vector of x values c In fc Real(*) function values f(xc) c In n Integer size of x c In epsm Real machine precision c In scalex Real(*) scaling vector for x() c Wk fz Real(*) workspace c Wk wa Real(*) workspace c Wk xw Real(*) workspace c In fvec Name name of routine to evaluate f(x) c Out termcd Integer return code c 0 user supplied jacobian ok c -10 user supplied jacobian NOT ok c c------------------------------------------------------------------------- integer i,j,k,dsum,errcnt double precision ndigit,p,h,dinf double precision tol double precision w(n),xstep(n) integer MAXERR parameter(MAXERR=10) double precision Rquart, Rten, Rzero parameter(Rquart=0.25d0, Rten=10.0d0, Rzero=0.0d0) dsum = dsub + dsuper + 1 termcd = 0 c compute the finite difference jacobian and check it against c the user supplied one ndigit = -log10(epsm) p = sqrt(max(Rten**(-ndigit),epsm)) tol = epsm**Rquart errcnt = 0 call dcopy(n,xc,1,xw,1) call vunsc(n,xw,scalex) do j=1,n xstep(j) = p + p * abs(xw(j)) w(j) = xw(j) enddo do k=1,dsum do j=k,n,dsum xw(j) = xw(j) + xstep(j) enddo c for non finite values error message will be wrong call fvec(xw,fz,n,n+k) do j=k,n,dsum h = xstep(j) xw(j) = w(j) dinf = Rzero do i=max(j-dsuper,1),min(j+dsub,n) wa(i) = (fz(i)-fc(i)) / h if(abs(wa(i)).gt.dinf) dinf = abs(wa(i)) enddo do i=max(j-dsuper,1),min(j+dsub,n) if(abs(A(i,j)-wa(i)).gt.tol*dinf) then errcnt = errcnt + 1 if( errcnt .gt. MAXERR ) then termcd = -10 return endif call nwckot(i,j,A(i,j),wa(i)) endif enddo enddo enddo c call vscal(n,xc,scalex) if( errcnt .gt. 0 ) then termcd = -10 endif return end c----------------------------------------------------------------------- subroutine chkjac(A,lda,xc,fc,n,epsm,jacflg,scalex,fz,wa,xw,fvec, * termcd) integer lda,n,termcd,jacflg(*) double precision A(lda,*),xc(*),fc(*) double precision epsm,scalex(*) double precision fz(*),wa(*),xw(*) external fvec c------------------------------------------------------------------------- c c Check the user supplied jacobian against its finite difference approximation c c Arguments c c In A Real(lda,*) user supplied jacobian c In lda Integer leading dimension of ajanal c In xc Real(*) vector of x values c In fc Real(*) function values f(xc) c In n Integer size of x c In epsm Real machine precision c In jacflg Integer(*) indicates how to compute jacobian c jacflg[1]: 0 numeric; 1 user supplied; 2 numerical banded c 3: user supplied banded c jacflg[2]: number of sub diagonals or -1 if not banded c jacflg[3]: number of super diagonals or -1 if not banded c jacflg[4]: 1 if adjusting jacobian allowed when c singular or illconditioned c In scalex Real(*) scaling vector for x() c Wk fz Real(*) workspace c Wk wa Real(*) workspace c Wk xw Real(*) workspace c In fvec Name name of routine to evaluate f(x) c Out termcd Integer return code c 0 user supplied jacobian ok c -10 user supplied jacobian NOT ok c c------------------------------------------------------------------------- if(jacflg(1) .eq. 3) then c user supplied and banded call chkjac2(A,lda,xc,fc,n,epsm,scalex,fz,wa,xw,fvec,termcd, * jacflg(2),jacflg(3)) else call chkjac1(A,lda,xc,fc,n,epsm,scalex,fz,wa,xw,fvec,termcd) endif return end c----------------------------------------------------------------------- subroutine fdjac0(xc,fc,n,epsm,fvec,fz,rjac,ldr) integer ldr,n double precision epsm double precision rjac(ldr,*),fz(*),xc(*),fc(*) external fvec c------------------------------------------------------------------------- c c Compute the finite difference jacobian at the current point xc c c Arguments c c In xc Real(*) current point c In fc Real(*) function values at current point c In n Integer size of x and f c In epsm Real machine precision c In fvec Name name of routine to evaluate f(x) c Wk fz Real(*) workspace c Out rjac Real(ldr,*) jacobian matrix at x c entry [i,j] is derivative of c f(i) wrt to x(j) c In ldr Integer leading dimension of rjac c c------------------------------------------------------------------------- integer i,j double precision ndigit,p,h,xcj double precision rnudif double precision Rten parameter(Rten=10d0) ndigit = -log10(epsm) p = sqrt(max(Rten**(-ndigit),epsm)) do j=1,n h = p + p * abs(xc(j)) c or as alternative h = p * max(Rone, abs(xc(j))) xcj = xc(j) xc(j) = xcj + h c avoid (small) rounding errors c h = xc(j) - xcj but not here to avoid clever optimizers h = rnudif(xc(j), xcj) call fvec(xc,fz,n,j) xc(j) = xcj do i=1,n rjac(i,j) = (fz(i)-fc(i)) / h enddo enddo return end c----------------------------------------------------------------------- subroutine fdjac2(xc,fc,n,epsm,fvec,fz,rjac,ldr,dsub,dsuper, * w,xstep) integer ldr,n,dsub,dsuper double precision epsm double precision rjac(ldr,*),fz(*),xc(*),fc(*) double precision w(*), xstep(*) external fvec c------------------------------------------------------------------------- c c Compute a banded finite difference jacobian at the current point xc c c Arguments c c In xc Real(*) current point c In fc Real(*) function values at current point c In n Integer size of x and f c In epsm Real machine precision c In fvec Name name of routine to evaluate f(x) c Wk fz Real(*) workspace c Out rjac Real(ldr,*) jacobian matrix at x c entry [i,j] is derivative of c f(i) wrt to x(j) c In ldr Integer leading dimension of rjac c In dsub Integer number of subdiagonals c In dsuper Integer number of superdiagonals c Internal w Real(*) for temporary saving of xc c Internal xstep Real(*) stepsizes c c------------------------------------------------------------------------- integer i,j,k double precision ndigit,p,h double precision rnudif double precision Rten parameter(Rten=10d0) integer dsum dsum = dsub + dsuper + 1 ndigit = -log10(epsm) p = sqrt(max(Rten**(-ndigit),epsm)) do k=1,n xstep(k) = p + p * abs(xc(k)) enddo do k=1,dsum do j=k,n,dsum w(j) = xc(j) xc(j) = xc(j) + xstep(j) enddo call fvec(xc,fz,n,n+k) do j=k,n,dsum call nuzero(n,rjac(1,j)) c fdjac0 for why c doing this ensures that results for fdjac2 and fdjac0 will be identical h = rnudif(xc(j),w(j)) xc(j) = w(j) do i=max(j-dsuper,1),min(j+dsub,n) rjac(i,j) = (fz(i)-fc(i)) / h enddo enddo enddo return end c----------------------------------------------------------------------- function nudnrm(n, d, x) integer n double precision d(*), x(*) double precision nudnrm c------------------------------------------------------------------------- c c calculate max( abs(d[*]) / max(x[*],1) ) c c Arguments c c In n Integer number of elements in d() and x() c In d Real(*) vector d c In x Real(*) vector x c c------------------------------------------------------------------------- integer i double precision t double precision Rzero, Rone parameter(Rzero=0.0d0, Rone=1.0d0) t = Rzero do i=1,n t = max(t, abs(d(i)) / max(abs(x(i)),Rone)) enddo nudnrm = t return end c----------------------------------------------------------------------- function nuxnrm(n, xn, xc) integer n double precision xn(*), xc(*) double precision nuxnrm c------------------------------------------------------------------------- c c calculate max( abs(xn[*]-xc[*]) / max(xn[*],1) ) c c Arguments c c In n Integer number of elements in xn() and xc() c In xn Real(*) vector xn c In xc Real(*) vector xc c c------------------------------------------------------------------------- integer i double precision t double precision Rzero, Rone parameter(Rzero=0.0d0, Rone=1.0d0) t = Rzero do i=1,n t = max(t, abs(xn(i)-xc(i)) / max(abs(xn(i)),Rone)) enddo nuxnrm = t return end c----------------------------------------------------------------------- function rnudif(x, y) double precision x, y double precision rnudif c------------------------------------------------------------------------- c c Return difference of x and y (x - y) c c Arguments c c In x Real argument 1 c In y Real argument 2 c c------------------------------------------------------------------------- rnudif = x - y return end c----------------------------------------------------------------------- subroutine compmu(r,ldr,n,mu,y,ierr) integer ldr,n,ierr double precision r(ldr,*),mu,y(*) c------------------------------------------------------------------------- c c Compute a small perturbation mu for the (almost) singular matrix R. c mu is used in the computation of the Levenberg-Marquardt step. c c Arguments c c In R Real(ldr,*) upper triangular matrix from QR c In ldr Integer leading dimension of R c In n Integer column dimension of R c Out mu Real sqrt(l1 norm of R * infinity norm of R c * n * epsm * 100) designed to make c trans(R)*R + mu * I not singular c Wk y Real(*) workspace for dlange c Out ierr Integer 0 indicating mu ok c 3 indicating mu much too small c c------------------------------------------------------------------------- double precision aifnrm,al1nrm,epsm double precision dlantr double precision epsmch double precision Rhund parameter(Rhund=100d0) c get the infinity norm of R c get the l1 norm of R ierr = 0 aifnrm = dlantr('I','U','N',n,n,r,ldr,y) al1nrm = dlantr('1','U','N',n,n,r,ldr,y) epsm = epsmch() mu = sqrt(n*epsm*Rhund)*aifnrm*al1nrm c matrix consists of zero's or near zero's c LM correction in liqrev will not work if( mu .le. Rhund*epsm ) then ierr = 3 endif return end c----------------------------------------------------------------------- subroutine cndjac(n,r,ldr,cndtol,rcond,rcdwrk,icdwrk,ierr) integer n,ldr,icdwrk(*),ierr double precision cndtol,rcond,r(ldr,*),rcdwrk(*) c--------------------------------------------------------------------- c c Check r for singularity and/or ill conditioning c c Arguments c c In n Integer dimension of problem c In r Real(ldr,*) upper triangular R from QR decomposition c In ldr Integer leading dimension of rjac c In cndtol Real tolerance of test for ill conditioning c when rcond <= cndtol then ierr is set to 1 c cndtol should be >= machine precision c Out rcond Real inverse condition of r c Wk rcdwrk Real(*) workspace (for dtrcon) c Wk icdwrk Integer(*) workspace (fordtrcon) c Out ierr Integer 0 indicating Jacobian not ill-conditioned or singular c 1 indicating Jacobian too ill-conditioned c 2 indicating Jacobian completely singular c c--------------------------------------------------------------------- integer i,info logical rsing double precision Rzero parameter(Rzero=0.0d0) ierr = 0 rsing = .false. do i=1,n if( r(i,i) .eq. Rzero ) then rsing = .true. endif enddo if( rsing ) then ierr = 2 rcond = Rzero else call dtrcon('1','U','N',n,r,ldr,rcond,rcdwrk,icdwrk,info) if( rcond .eq. Rzero ) then ierr = 2 elseif( rcond .le. cndtol ) then ierr = 1 endif endif return end c----------------------------------------------------------------------- subroutine nwfjac(x,scalex,f,fq,n,epsm,jacflg,fvec,mkjac,rjac, * ldr,xw,w,xstep) integer ldr,n,jacflg(*) double precision epsm double precision x(*),f(*),scalex(*),xw(*),w(*),xstep(*) double precision rjac(ldr,*),fq(*) external fvec,mkjac c------------------------------------------------------------------------- c c Calculate the jacobian matrix c c Arguments c c In x Real(*) (scaled) current x values c In scalex Real(*) scaling factors x c In f Real(*) function values f(x) c Wk fq Real(*) (internal) workspace c In n Integer size of x and f c In epsm Real machine precision c In jacflg Integer(*) indicates how to compute jacobian c jacflg[1]: 0 numeric; 1 user supplied; 2 numerical banded c 3: user supplied banded c jacflg[2]: number of sub diagonals or -1 if not banded c jacflg[3]: number of super diagonals or -1 if not banded c jacflg[4]: 1 if adjusting jacobian allowed when c singular or illconditioned c In fvec Name name of routine to evaluate f() c In mkjac Name name of routine to evaluate jacobian c Out rjac Real(ldr,*) jacobian matrix (unscaled) c In ldr Integer leading dimension of rjac c Internal xw Real(*) used for storing unscaled x c Internal w Real(*) workspace for banded jacobian c Internal xstep Real(*) workspace for banded jacobian c c------------------------------------------------------------------------- c compute the finite difference or analytic jacobian at x call dcopy(n,x,1,xw,1) call vunsc(n,xw,scalex) if(jacflg(1) .eq. 0) then call fdjac0(xw,f,n,epsm,fvec,fq,rjac,ldr) elseif(jacflg(1) .eq. 2) then call fdjac2(xw,f,n,epsm,fvec,fq,rjac,ldr,jacflg(2),jacflg(3), * w,xstep) else call mkjac(rjac,ldr,xw,n) endif return end c----------------------------------------------------------------------- subroutine nwscjac(n,rjac,ldr,scalex) integer n, ldr double precision rjac(ldr,*), scalex(*) c------------------------------------------------------------------------- c c Scale jacobian c c Arguments c c In n Integer size of x and f c Inout rjac Real(ldr,*) jacobian matrix c In ldr Integer leading dimension of rjac c In scalex Real(*) scaling factors for x c c------------------------------------------------------------------------- integer j double precision t, Rone parameter(Rone=1.0d0) do j = 1,n t = Rone/scalex(j) call dscal(n,t,rjac(1,j),1) enddo return end c----------------------------------------------------------------------- subroutine nwunscjac(n,rjac,ldr,scalex) integer n, ldr double precision rjac(ldr,*), scalex(*) c------------------------------------------------------------------------- c c Unscale jacobian c c Arguments c c In n Integer size of x and f c Inout rjac Real(ldr,*) jacobian matrix c In ldr Integer leading dimension of rjac c In scalex Real(*) scaling factors for x c c------------------------------------------------------------------------- integer j double precision t do j = 1,n t = scalex(j) call dscal(n,t,rjac(1,j),1) enddo return end c----------------------------------------------------------------------- subroutine nwcpsx(n,rjac,ldr,scalex,epsm, mode) integer ldr,n,mode double precision epsm double precision scalex(*) double precision rjac(ldr,*) c------------------------------------------------------------------------- c c Calculate scaling factors from the jacobian matrix c c Arguments c c In n Integer size of x and f c In rjac Real(ldr,*) jacobian matrix c In ldr Integer leading dimension of rjac c Out scalex Real(*) scaling factors for x c In epsm Real machine precision c In mode Integer 1: initialise, >1: adjust c------------------------------------------------------------------------- integer k double precision dnrm2 if( mode .eq. 1 ) then do k=1,n scalex(k) = dnrm2(n,rjac(1,k),1) if( scalex(k) .le. epsm ) scalex(k) = 1 enddo else if( mode .gt. 1 ) then do k=1,n scalex(k) = max(scalex(k),dnrm2(n,rjac(1,k),1)) enddo endif return end c----------------------------------------------------------------------- subroutine nwcpmt(n, x, scalex, factor, wrk, stepsiz) double precision x(*), scalex(*), wrk(*) double precision factor, stepsiz integer n c------------------------------------------------------------------------- c c Calculate maximum stepsize c c Arguments c c In n Integer size of x c In x Real(*) x-values c In scalex Real(*) scaling factors for x c In factor Real multiplier c Inout wrk Real(*) workspace c Out stepsiz Real stepsize c c Currently not used c Minpack uses this to calculate initial trust region size c Not (yet) used in this code because it doesn't seem to help c Manually setting an initial trust region size works better c c------------------------------------------------------------------------- double precision Rzero parameter(Rzero=0.0d0) double precision dnrm2 call dcopy(n,x,1,wrk,1) call vscal(n,wrk,scalex) stepsiz = factor * dnrm2(n,wrk,1) if( stepsiz .eq. Rzero ) stepsiz = factor return end c----------------------------------------------------------------------- subroutine vscal(n,x,sx) integer n double precision x(*),sx(*) c------------------------------------------------------------------------- c c Scale a vector x c c Arguments c c In n Integer size of x c Inout x Real(*) vector to scale c In sx Real(*) scaling vector c c------------------------------------------------------------------------- integer i do i = 1,n x(i) = sx(i) * x(i) enddo return end c----------------------------------------------------------------------- subroutine vunsc(n,x,sx) integer n double precision x(*),sx(*) c------------------------------------------------------------------------- c c Unscale a vector x c c Arguments c c In n Integer size of x c Inout x Real(*) vector to unscale c In sx Real(*) scaling vector c c------------------------------------------------------------------------- integer i do i = 1,n x(i) = x(i) / sx(i) enddo return end c----------------------------------------------------------------------- subroutine nwfvec(x,n,scalex,fvec,f,fnorm,xw) integer n double precision x(*),xw(*),scalex(*),f(*),fnorm external fvec c------------------------------------------------------------------------- c c Evaluate the function at current iterate x and scale its value c c Arguments c c In x Real(*) x c In n Integer size of x c In scalex Real(*) scaling vector for x c In fvec Name name of routine to calculate f(x) c Out f Real(*) f(x) c Out fnorm Real .5*||f(x)||**2 c Internal xw Real(*) used for storing unscaled xc c c------------------------------------------------------------------------- double precision dnrm2 double precision Rhalf parameter(Rhalf=0.5d0) call dcopy(n,x,1,xw,1) call vunsc(n,xw,scalex) call fvec(xw,f,n,0) fnorm = Rhalf * dnrm2(n,f,1)**2 return end c----------------------------------------------------------------------- function epsmch() c Return machine precision c Use Lapack routine double precision epsmch double precision dlamch external dlamch c dlamch('e') returns negeps (1-eps) c dlamch('p') returns 1+eps epsmch = dlamch('p') return end c----------------------------------------------------------------------- function dblhuge() c Return largest double precision number c Use Lapack routine double precision dblhuge double precision dlamch external dlamch c dlamch('o') returns max double precision dblhuge = dlamch('o') return end nleqslv/src/nwnwtn.f0000755000175100001440000002325013127132302014244 0ustar hornikusers subroutine nwsolv(ldr,xc,n,scalex,maxit, * jacflg,xtol,ftol,btol,cndtol,global,xscalm, * stepmx,delta,sigma, * rjac,wrk1,wrk2,wrk3,wrk4,fc,fq,dn,d,qtf, * rcdwrk,icdwrk,qrwork,qrwsiz,epsm, * fjac,fvec,outopt,xp,fp,gp,njcnt,nfcnt,iter, * termcd) integer ldr,n,termcd,njcnt,nfcnt,iter integer maxit,jacflg(*),global,xscalm,qrwsiz integer outopt(*) double precision xtol,ftol,btol,cndtol double precision stepmx,delta,sigma,fpnorm,epsm double precision rjac(ldr,*) double precision xc(*),fc(*),xp(*),fp(*),dn(*),d(*) double precision wrk1(*),wrk2(*),wrk3(*),wrk4(*) double precision qtf(*),gp(*),fq(*) double precision scalex(*) double precision rcdwrk(*),qrwork(*) integer icdwrk(*) external fjac,fvec c----------------------------------------------------------------------- c c Solve system of nonlinear equations with Newton and global strategy c c c Arguments c c In ldr Integer leading dimension of rjac c In xc Real(*) initial estimate of solution c In n Integer dimensions of problem c Inout scalex Real(*) scaling factors x(*) c In maxit Integer maximum number of allowable iterations c In jacflg Integer(*) jacobian flag array c jacflg[1]: 0 numeric; 1 user supplied; 2 numerical banded c 3: user supplied banded c jacflg[2]: number of sub diagonals or -1 if not banded c jacflg[3]: number of super diagonals or -1 if not banded c jacflg[4]: 1 if adjusting step allowed when c singular or illconditioned c In xtol Real tolerance at which successive iterates x() c are considered close enough to c terminate algorithm c In ftol Real tolerance at which function values f() c are considered close enough to zero c Inout btol Real x tolerance for backtracking c Inout cndtol Real tolerance of test for ill conditioning c In global Integer global strategy to use c 1 cubic linesearch c 2 quadratic linesearch c 3 geometric linesearch c 4 double dogleg c 5 powell dogleg c 6 hookstep (More-Hebden Levenberg-Marquardt) c In xscalm Integer x scaling method c 1 from column norms of first jacobian c increased if needed after first iteration c 0 scaling user supplied c In stepmx Real maximum allowable step size c In delta Real trust region radius c In sigma Real reduction factor geometric linesearch c Inout rjac Real(ldr,*) jacobian (n columns) c Wk wrk1 Real(*) workspace c Wk wrk2 Real(*) workspace c Wk wrk3 Real(*) workspace c Wk wrk4 Real(*) workspace c Inout fc Real(*) function values f(xc) c Wk fq Real(*) workspace c Wk dn Real(*) workspace c Wk d Real(*) workspace c Wk qtf Real(*) workspace c Wk rcdwrk Real(*) workspace c Wk icdwrk Integer(*) workspace c In qrwork Real(*) workspace for Lapack QR routines (call liqsiz) c In qrwsiz Integer size of qrwork c In epsm Real machine precision c In fjac Name name of routine to calculate jacobian c (optional) c In fvec Name name of routine to calculate f() c In outopt Integer(*) output options c Out xp Real(*) final x() c Out fp Real(*) final f(xp) c Out gp Real(*) gradient at xp() c Out njcnt Integer number of jacobian evaluations c Out nfcnt Integer number of function evaluations c Out iter Integer number of (outer) iterations c Out termcd Integer termination code c c----------------------------------------------------------------------- integer gcnt,retcd,ierr double precision dum(2),fcnorm,rcond logical fstjac integer priter integer idamax c initialization retcd = 0 iter = 0 njcnt = 0 nfcnt = 0 ierr = 0 dum(1) = 0 if( outopt(1) .eq. 1 ) then priter = 1 else priter = -1 endif c evaluate function call vscal(n,xc,scalex) call nwfvec(xc,n,scalex,fvec,fc,fcnorm,wrk1) c evaluate user supplied or finite difference jacobian and check user supplied c jacobian, if requested fstjac = .false. if(mod(jacflg(1),2) .eq. 1) then if( outopt(2) .eq. 1 ) then fstjac = .true. njcnt = njcnt + 1 call nwfjac(xc,scalex,fc,fq,n,epsm,jacflg,fvec,fjac,rjac, * ldr,wrk1,wrk2,wrk3) call chkjac(rjac,ldr,xc,fc,n,epsm,jacflg,scalex, * fq,wrk1,wrk2,fvec,termcd) if(termcd .lt. 0) then c copy initial values call dcopy(n,xc,1,xp,1) call dcopy(n,fc,1,fp,1) call vunsc(n,xp,scalex) fpnorm = fcnorm return endif endif endif c check stopping criteria for input xc call nwtcvg(xc,fc,xc,xtol,retcd,ftol,iter,maxit,n,ierr,termcd) if(termcd .gt. 0) then call dcopy(n,xc,1,xp,1) call dcopy(n,fc,1,fp,1) fpnorm = fcnorm if( outopt(3) .eq. 1 .and. .not. fstjac ) then njcnt = njcnt + 1 call nwfjac(xp,scalex,fp,fq,n,epsm,jacflg,fvec,fjac,rjac, * ldr,wrk1,wrk2,wrk3) endif return endif if( priter .gt. 0 ) then dum(1) = fcnorm dum(2) = abs(fc(idamax(n,fc,1))) if( global .eq. 0 ) then call nwprot(iter, -1, dum) elseif( global .le. 3 ) then call nwlsot(iter,-1,dum) elseif( global .eq. 4 ) then call nwdgot(iter,-1,0,dum) elseif( global .eq. 5 ) then call nwpwot(iter,-1,0,dum) elseif( global .eq. 6 ) then call nwmhot(iter,-1,0,dum) endif endif do while( termcd .eq. 0 ) iter = iter + 1 call nwnjac(rjac,ldr,n,xc,fc,fq,fvec,fjac,epsm,jacflg,wrk1, * wrk2,wrk3, * xscalm,scalex,gp,cndtol,rcdwrk,icdwrk,dn, * qtf,rcond,qrwork,qrwsiz,njcnt,iter,fstjac,ierr) c - choose the next iterate xp by a global strategy if( ierr .gt. 0 ) then c jacobian singular or too ill-conditioned call nweset(n,xc,fc,fcnorm,xp,fp,fpnorm,gcnt,priter,iter) elseif(global .eq. 0) then call nwpure(n,xc,dn,stepmx,scalex, * fvec,xp,fp,fpnorm,wrk1,retcd,gcnt, * priter,iter) elseif(global .eq. 1) then call nwclsh(n,xc,fcnorm,dn,gp,stepmx,btol,scalex, * fvec,xp,fp,fpnorm,wrk1,retcd,gcnt, * priter,iter) elseif(global .eq. 2) then call nwqlsh(n,xc,fcnorm,dn,gp,stepmx,btol,scalex, * fvec,xp,fp,fpnorm,wrk1,retcd,gcnt, * priter,iter) elseif(global .eq. 3) then call nwglsh(n,xc,fcnorm,dn,gp,sigma,stepmx,btol,scalex, * fvec,xp,fp,fpnorm,wrk1,retcd,gcnt, * priter,iter) elseif(global .eq. 4) then call nwddlg(n,rjac,ldr,dn,gp,xc,fcnorm,stepmx, * btol,delta,qtf,scalex, * fvec,d,fq,wrk1,wrk2,wrk3,wrk4, * xp,fp,fpnorm,retcd,gcnt,priter,iter) elseif(global .eq. 5) then call nwpdlg(n,rjac,ldr,dn,gp,xc,fcnorm,stepmx, * btol,delta,qtf,scalex, * fvec,d,fq,wrk1,wrk2,wrk3,wrk4, * xp,fp,fpnorm,retcd,gcnt,priter,iter) elseif(global .eq. 6) then call nwmhlm(n,rjac,ldr,dn,gp,xc,fcnorm,stepmx, * btol,delta,qtf,scalex, * fvec,d,fq,wrk1,wrk2,wrk3,wrk4, * xp,fp,fpnorm,retcd,gcnt,priter,iter) endif nfcnt = nfcnt + gcnt c - check stopping criteria for the new iterate xp call nwtcvg(xp,fp,xc,xtol,retcd,ftol,iter,maxit,n,ierr,termcd) if(termcd .eq. 0) then c update xc, fc, and fcnorm call dcopy(n,xp,1,xc,1) call dcopy(n,fp,1,fc,1) fcnorm = fpnorm endif enddo if( outopt(3) .eq. 1 ) then call nwfjac(xp,scalex,fp,fq,n,epsm,jacflg,fvec,fjac,rjac, * ldr,wrk1,wrk2,wrk3) endif call vunsc(n,xp,scalex) return end nleqslv/src/nwbrdn.f0000755000175100001440000003752713127132302014217 0ustar hornikusers subroutine brsolv(ldr,xc,n,scalex,maxit, * jacflg,xtol,ftol,btol,cndtol,global,xscalm, * stepmx,delta,sigma, * rjac,r,wrk1,wrk2,wrk3,wrk4,fc,fq,dn,d,qtf, * rcdwrk,icdwrk,qrwork,qrwsiz,epsm, * fjac,fvec,outopt,xp,fp,gp,njcnt,nfcnt,iter, * termcd) integer ldr,n,termcd,njcnt,nfcnt,iter integer maxit,jacflg(*),global,xscalm,qrwsiz integer outopt(*) double precision xtol,ftol,btol,cndtol double precision stepmx,delta,sigma,fpnorm,epsm double precision rjac(ldr,*),r(ldr,*) double precision xc(*),fc(*),xp(*),fp(*),dn(*),d(*) double precision wrk1(*),wrk2(*),wrk3(*),wrk4(*) double precision qtf(*),gp(*),fq(*) double precision scalex(*) double precision rcdwrk(*),qrwork(*) integer icdwrk(*) external fjac,fvec c----------------------------------------------------------------------- c c Solve system of nonlinear equations with Broyden and global strategy c c c Arguments c c In ldr Integer leading dimension of rjac c In xc Real(*) initial estimate of solution c In n Integer dimensions of problem c Inout scalex Real(*) scaling factors x(*) c In maxit Integer maximum number of allowable iterations c In jacflg Integer(*) jacobian flag array c jacflg[1]: 0 numeric; 1 user supplied; 2 numerical banded c 3: user supplied banded c jacflg[2]: number of sub diagonals or -1 if not banded c jacflg[3]: number of super diagonals or -1 if not banded c jacflg[4]: 1 if adjusting step allowed when c singular or illconditioned c In xtol Real tolerance at which successive iterates x() c are considered close enough to c terminate algorithm c In ftol Real tolerance at which function values f() c are considered close enough to zero c Inout btol Real x tolerance for backtracking c Inout cndtol Real tolerance of test for ill conditioning c In global Integer global strategy to use c 1 cubic linesearch c 2 quadratic linesearch c 3 geometric linesearch c 4 double dogleg c 5 powell dogleg c 6 hookstep (More-Hebden Levenberg-Marquardt) c In xscalm Integer x scaling method c 1 from column norms of first jacobian c increased if needed after first iteration c 0 scaling user supplied c In stepmx Real maximum allowable step size c In delta Real trust region radius c In sigma Real reduction factor geometric linesearch c Inout rjac Real(ldr,*) jacobian (n columns)(compact QR decomposition/Q matrix) c Inout r Real(ldr,*) stored R from QR decomposition c Wk wrk1 Real(*) workspace c Wk wrk2 Real(*) workspace c Wk wrk3 Real(*) workspace c Wk wrk4 Real(*) workspace c Inout fc Real(*) function values f(xc) c Wk fq Real(*) workspace c Wk dn Real(*) workspace c Wk d Real(*) workspace c Wk qtf Real(*) workspace c Wk rcdwrk Real(*) workspace c Wk icdwrk Integer(*) workspace c In qrwork Real(*) workspace for Lapack QR routines (call liqsiz) c In qrwsiz Integer size of qrwork c In epsm Real machine precision c In fjac Name name of routine to calculate jacobian c (optional) c In fvec Name name of routine to calculate f() c In outopt Integer(*) output options c Out xp Real(*) final x() c Out fp Real(*) final f(xp) c Out gp Real(*) gradient at xp() c Out njcnt Integer number of jacobian evaluations c Out nfcnt Integer number of function evaluations c Out iter Integer number of (outer) iterations c Out termcd Integer termination code c c----------------------------------------------------------------------- integer gcnt,retcd,ierr double precision dum(2),dlt0,fcnorm,rcond logical fstjac logical jacevl,jacupd logical stepadj integer priter integer idamax double precision Rone parameter(Rone=1.0d0) c initialization retcd = 0 iter = 0 njcnt = 0 nfcnt = 0 ierr = 0 dum(1) = 0 dlt0 = delta if( outopt(1) .eq. 1 ) then priter = 1 else priter = -1 endif c evaluate function call vscal(n,xc,scalex) call nwfvec(xc,n,scalex,fvec,fc,fcnorm,wrk1) c evaluate user supplied or finite difference jacobian and check user supplied c jacobian, if requested fstjac = .false. if(mod(jacflg(1),2) .eq. 1) then if( outopt(2) .eq. 1 ) then fstjac = .true. njcnt = njcnt + 1 call nwfjac(xc,scalex,fc,fq,n,epsm,jacflg,fvec,fjac,rjac, * ldr,wrk1,wrk2,wrk3) call chkjac(rjac,ldr,xc,fc,n,epsm,jacflg,scalex, * fq,wrk1,wrk2,fvec,termcd) if(termcd .lt. 0) then c copy initial values call dcopy(n,xc,1,xp,1) call dcopy(n,fc,1,fp,1) call vunsc(n,xp,scalex) fpnorm = fcnorm return endif endif endif c check stopping criteria for input xc call nwtcvg(xc,fc,xc,xtol,retcd,ftol,iter,maxit,n,ierr,termcd) if(termcd .gt. 0) then call dcopy(n,xc,1,xp,1) call dcopy(n,fc,1,fp,1) fpnorm = fcnorm if( outopt(3) .eq. 1 .and. .not. fstjac ) then njcnt = njcnt + 1 call nwfjac(xp,scalex,fp,fq,n,epsm,jacflg,fvec,fjac,rjac, * ldr,wrk1,wrk2,wrk3) endif return endif if( priter .gt. 0 ) then dum(1) = fcnorm dum(2) = abs(fc(idamax(n,fc,1))) if( global .eq. 0 ) then call nwprot(iter, -1, dum) elseif( global .le. 3 ) then call nwlsot(iter,-1,dum) elseif( global .eq. 4 ) then call nwdgot(iter,-1,0,dum) elseif( global .eq. 5 ) then call nwpwot(iter,-1,0,dum) elseif( global .eq. 6 ) then call nwmhot(iter,-1,0,dum) endif endif jacevl = .true. stepadj = jacflg(4) .eq. 1 do while( termcd .eq. 0 ) iter = iter+1 if( jacevl ) then call nwbjac(rjac,r,ldr,n,xc,fc,fq,fvec,fjac,epsm,jacflg, * wrk1,wrk2,wrk3, * xscalm,scalex,gp,cndtol,rcdwrk,icdwrk,dn, * qtf,rcond,qrwork,qrwsiz,njcnt,iter,fstjac,ierr) else c - get broyden step c - calculate approximate gradient call dcopy(n,fc,1,fq,1) call brodir(rjac,ldr,r,fq,n,cndtol, stepadj, * dn,qtf,ierr,rcond,rcdwrk,icdwrk) if( ierr .eq. 0 ) then call dcopy(n,qtf,1,gp,1) call dtrmv('U','T','N',n,r,ldr,gp,1) endif endif c - choose the next iterate xp by a global strategy if( ierr .gt. 0 ) then c jacobian singular or too ill-conditioned call nweset(n,xc,fc,fcnorm,xp,fp,fpnorm,gcnt,priter,iter) elseif(global .eq. 0) then call nwpure(n,xc,dn,stepmx,scalex, * fvec,xp,fp,fpnorm,wrk1,retcd,gcnt, * priter,iter) elseif(global .eq. 1) then call nwclsh(n,xc,fcnorm,dn,gp,stepmx,btol,scalex, * fvec,xp,fp,fpnorm,wrk1,retcd,gcnt, * priter,iter) elseif(global .eq. 2) then call nwqlsh(n,xc,fcnorm,dn,gp,stepmx,btol,scalex, * fvec,xp,fp,fpnorm,wrk1,retcd,gcnt, * priter,iter) elseif(global .eq. 3) then call nwglsh(n,xc,fcnorm,dn,gp,sigma,stepmx,btol,scalex, * fvec,xp,fp,fpnorm,wrk1,retcd,gcnt, * priter,iter) elseif(global .eq. 4) then call nwddlg(n,r,ldr,dn,gp,xc,fcnorm,stepmx, * btol,delta,qtf,scalex, * fvec,d,fq,wrk1,wrk2,wrk3,wrk4, * xp,fp,fpnorm,retcd,gcnt,priter,iter) elseif(global .eq. 5) then call nwpdlg(n,r,ldr,dn,gp,xc,fcnorm,stepmx, * btol,delta,qtf,scalex, * fvec,d,fq,wrk1,wrk2,wrk3,wrk4, * xp,fp,fpnorm,retcd,gcnt,priter,iter) elseif(global .eq. 6) then call nwmhlm(n,r,ldr,dn,gp,xc,fcnorm,stepmx, * btol,delta,qtf,scalex, * fvec,d,fq,wrk1,wrk2,wrk3,wrk4, * xp,fp,fpnorm,retcd,gcnt,priter,iter) endif nfcnt = nfcnt + gcnt c - check stopping criteria for the new iterate xp call nwtcvg(xp,fp,xc,xtol,retcd,ftol,iter,maxit,n,ierr,termcd) if( termcd .eq. 3 .and. .not. jacevl ) then c global strategy failed but jacobian is out of date c try again with proper jacobian c reset trust region radius jacevl = .true. jacupd = .false. delta = dlt0 termcd = 0 elseif(termcd .gt. 0) then jacupd = .false. else jacupd = .true. jacevl = .false. endif if( jacupd ) then c perform Broyden update of current jacobian c update xc, fc, and fcnorm call brupdt(n,rjac,r,ldr,xc,xp,fc,fp,epsm, * wrk1,wrk2,wrk3) call dcopy(n,xp,1,xc,1) call dcopy(n,fp,1,fc,1) fcnorm = fpnorm endif enddo if( outopt(3) .eq. 1 ) then c final update of jacobian call brupdt(n,rjac,r,ldr,xc,xp,fc,fp,epsm, * wrk1,wrk2,wrk3) c reconstruct Broyden matrix c calculate Q * R where Q is overwritten by result c Q is in rjac and R is in r call dtrmm('R','U','N','N',n,n,Rone,r,n,rjac,n) c unscale call nwunscjac(n,rjac,ldr,scalex) endif call vunsc(n,xp,scalex) return end c----------------------------------------------------------------------- subroutine brupdt(n,q,r,ldr,xc,xp,fc,fp,epsm,dx,df,wa) integer n,ldr double precision q(ldr,*),r(ldr,*) double precision xc(*),xp(*),fc(*),fp(*),dx(*),df(*),wa(*) double precision epsm c----------------------------------------------------------------------- c c Calculate new Q and R from rank-1 update with xp-xc and fp-fc c using Broyden method c c Arguments c c In n Integer size of xc() etc. c Inout Q Real(ldr,n) orthogonal matrix Q from QR c On output updated Q c Inout R Real(ldr,n) upper triangular R from QR c On output updated R c In ldr Integer leading dimension of Q and R c In xc Real(*) current x() values c In xp Real(*) new x() values c In fc Real(*) current f(xc) c In fp Real(*) new f(xp) c In epsm Real machine precision c Wk dx Real(*) workspace c Wk df Real(*) workspace c Wk wa Real(*) workspace c c----------------------------------------------------------------------- integer i double precision eta,sts double precision dnrm2 logical doupdt double precision Rzero, Rone, Rtwo, Rhund parameter(Rzero=0.0d0, Rone=1.0d0, Rtwo=2.0d0, Rhund=100d0) eta = Rhund * Rtwo * epsm doupdt = .false. do i=1,n dx(i) = xp(i) - xc(i) df(i) = fp(i) - fc(i) enddo c clear lower triangle do i=1,n-1 call nuzero(n-i,r(i+1,i)) enddo c calculate df - B*dx = df - Q*R*dx c wa = R*dx c df = df - Q*(R*dx) (!not really needed if qrupdt were to be changed) c do not update with noise call dcopy(n,dx,1,wa,1) call dtrmv('U','N','N',n,r,ldr,wa,1) call dgemv('N',n,n,-Rone,q,ldr,wa,1,Rone,df,1) do i=1,n if( abs(df(i)) .gt. eta*( abs(fp(i)) + abs(fc(i)) ) ) then doupdt = .true. else df(i) = Rzero endif enddo if( doupdt ) then c equation 8.3.1 from Dennis and Schnabel (page 187)(Siam edition) sts = dnrm2(n,dx,1) call dscal(n,Rone/sts,dx,1) call dscal(n,Rone/sts,df,1) call liqrup(q,ldr,n,r,ldr,df,dx,wa) endif return end c----------------------------------------------------------------------- subroutine brodir(q,ldr,r,fn,n,cndtol,stepadj,dn,qtf, * ierr,rcond,rcdwrk,icdwrk) integer ldr,n,ierr double precision cndtol,q(ldr,*),r(ldr,*),fn(*) double precision dn(*),qtf(*) double precision rcdwrk(*) integer icdwrk(*) double precision rcond logical stepadj c----------------------------------------------------------------------- c c Calculate the approximate newton direction c c Arguments c c Inout Q Real(ldr,*) Q part from QR at current iterate c In ldr Integer leading dimension of Q and R c In R Real(ldr,*) upper triangular R from QR decomposition c In fn Real(*) function values at current iterate c In n Integer dimension of problem c In cndtol Real tolerance of test for ill conditioning c In stepadj Logical allow adjusting step for singular/illconditioned jacobian c Out dn Real(*) Newton direction c Out qtf Real(*) trans(Q)*f() c Out ierr Integer 0 indicating Jacobian not ill-conditioned or singular c 1 indicating Jacobian ill-conditioned c 2 indicating Jacobian completely singular c 3 indicating almost zero LM correction c Out rcond Real inverse condition of matrix c Wk rcdwrk Real(*) workspace c Wk icdwrk Integer(*) workspace c c QR decomposition with no pivoting. c c----------------------------------------------------------------------- double precision Rzero, Rone parameter(Rzero=0.0d0, Rone=1.0d0) c form qtf = trans(Q) * fn call dgemv('T',n,n,Rone,q,ldr,fn,1,Rzero,qtf,1) call lirslv(R,ldr,n,cndtol, stepadj, * qtf,dn,ierr,rcond, rcdwrk,icdwrk) call nwsnot(1,ierr,rcond) return end nleqslv/src/init.c0000644000175100001440000000125613127132302013650 0ustar hornikusers#include #include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void deactivatenleq(); /* .Call calls */ extern SEXP nleqslv(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); static const R_CMethodDef CEntries[] = { {"deactivatenleq", (DL_FUNC) &deactivatenleq, 0}, {NULL, NULL, 0} }; static const R_CallMethodDef CallEntries[] = { {"nleqslv", (DL_FUNC) &nleqslv, 9}, {NULL, NULL, 0} }; void R_init_nleqslv(DllInfo *dll) { R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } nleqslv/src/nwpdlg.f0000755000175100001440000001643513127132302014213 0ustar hornikusers subroutine nwpdlg(n,rjac,ldr,dn,g,xc,fcnorm,stepmx,xtol, * delta,qtf,scalex,fvec,d,xprev, * ssd,v,wa,fprev,xp,fp,fpnorm,retcd,gcnt, * priter,iter) integer ldr, n, retcd, gcnt, priter, iter double precision fcnorm, stepmx, xtol, fpnorm, delta double precision rjac(ldr,*), dn(*), g(*), xc(*), qtf(*) double precision scalex(*), d(*) double precision xprev(*), xp(*), fp(*) double precision ssd(*), v(*), wa(*), fprev(*) external fvec c------------------------------------------------------------------------- c c Find a next iterate xp by the Powell dogleg method c c Arguments c c In n Integer size of problem: dimension x, f c In Rjac Real(ldr,*) R of QR-factored jacobian c In ldr Integer leading dimension of Rjac c Inout dn Real(*) newton direction c Inout g Real(*) gradient at current point c trans(jac)*f() c In xc Real(*) current iterate c In fcnorm Real .5*||f(xc)||**2 c In stepmx Real maximum stepsize c In xtol Real x-tolerance (stepsize) c Inout delta Real on input: initial trust region radius c if -1 then set to something c reasonable c on output: final value c ! Do not modify between calls while c still iterating c In qtf Real(*) trans(Q)*f(xc) c In scalex Real(*) scaling factors for x() c In fvec Name name of subroutine to evaluate f(x) c ! must be declared external in caller c Wk d Real(*) work vector c Wk xprev Real(*) work vector c Wk ssd Real(*) work vector c Wk v Real(*) work vector c Wk wa Real(*) work vector c Wk fprev Real(*) work vector c Out xp Real(*) new x() c Out fp Real(*) new f(xp) c Out fpnorm Real new .5*||f(xp)||**2 c Out retcd Integer return code c 0 new satisfactory x() found c 1 no satisfactory x() found c Out gcnt Integer number of steps taken c In priter Integer print flag c -1 no intermediate printing c >0 yes for print of intermediate results c In iter Integer current iteration (only used for above) c c All vectors at least size n c c------------------------------------------------------------------------- integer i double precision dnlen,ssdlen,alpha,beta,lambda,fpred double precision sqalpha,fpnsav,oarg(5) double precision dnrm2 logical nwtstep integer dtype integer idamax double precision Rone, Rtwo, Rhalf parameter(Rhalf=0.5d0) parameter(Rone=1.0d0, Rtwo=2.0d0) c length newton direction dnlen = dnrm2(n, dn, 1) c steepest descent direction and length sqalpha = dnrm2(n,g,1) alpha = sqalpha**2 call dcopy(n, g, 1, d, 1) call dtrmv('U','N','N',n,rjac,ldr,d,1) beta = dnrm2(n,d,1)**2 call dcopy(n, g, 1, ssd, 1) call dscal(n, -(alpha/beta), ssd, 1) ssdlen = alpha*sqalpha/beta c set trust radius to ssdlen or dnlen if required if( delta .eq. -Rone ) then delta = min(ssdlen, stepmx) elseif( delta .eq. -Rtwo ) then delta = min(dnlen, stepmx) endif retcd = 4 gcnt = 0 do while( retcd .gt. 1 ) c find new step by single dogleg algorithm call pwlstp(n,dn,dnlen,delta,v, * ssd,ssdlen,d,dtype,lambda) nwtstep = dtype .eq. 3 c compute the model prediction 0.5*||F + J*d||**2 (L2-norm) call dcopy(n,d,1,wa,1) call dtrmv('U','N','N',n,rjac,ldr,wa,1) call daxpy(n, Rone, qtf,1,wa,1) fpred = Rhalf * dnrm2(n,wa,1)**2 c evaluate function at xp = xc + d do i=1,n xp(i) = xc(i) + d(i) enddo call nwfvec(xp,n,scalex,fvec,fp,fpnorm,wa) gcnt = gcnt + 1 c check whether the global step is acceptable oarg(2) = delta call nwtrup(n,fcnorm,g,d,nwtstep,stepmx,xtol,delta, * fpred,retcd,xprev,fpnsav,fprev,xp,fp,fpnorm) if( priter .gt. 0 ) then oarg(1) = lambda oarg(3) = delta oarg(4) = fpnorm oarg(5) = abs(fp(idamax(n,fp,1))) call nwpwot(iter,dtype,retcd,oarg) endif enddo return end c----------------------------------------------------------------------- subroutine pwlstp(n,dn,dnlen,delta,v, * ssd,ssdlen,d,dtype,lambda) integer n double precision dn(*), ssd(*), v(*), d(*) double precision dnlen, delta, ssdlen, lambda integer dtype c------------------------------------------------------------------------- c c Find a new step by the Powell dogleg algorithm c Internal routine for nwpdlg c c Arguments c c In n Integer size of problem c In dn Real(*) current newton step c Out dnlen Real length dn() c In delta Real current trust region radius c Out v Real(*) (internal) dn() - ssd() c In ssd Real(*) (internal) steepest descent direction c In ssdlen Real (internal) length ssd c Out d Real(*) new step for x() c Out dtype Integer steptype c 1 steepest descent c 2 combination of dn and ssd c 3 full newton direction c Out lambda Real weight of dn() in d() c closer to 1 ==> more of dn() c c----------------------------------------------------------------------- integer i double precision vssd, vlen double precision dnrm2, ddot if(dnlen .le. delta) then c Newton step smaller than trust radius ==> take it call dcopy(n, dn, 1, d, 1) delta = dnlen dtype = 3 elseif(ssdlen .ge. delta) then c take step in steepest descent direction call dcopy(n, ssd, 1, d, 1) call dscal(n, delta / ssdlen, d, 1) dtype = 1 else c calculate convex combination of ssd and dn with length delta do i=1,n v(i) = dn(i) - ssd(i) enddo vssd = ddot(n,v,1,ssd,1) vlen = dnrm2(n,v,1)**2 lambda =(-vssd+sqrt(vssd**2-vlen*(ssdlen**2-delta**2)))/vlen call dcopy(n, ssd, 1, d, 1) call daxpy(n, lambda, v, 1, d, 1) dtype = 2 endif return end nleqslv/NAMESPACE0000644000175100001440000000020713051063122013163 0ustar hornikusersuseDynLib(nleqslv, .registration=TRUE, .fixes="C_") export(nleqslv) export(testnslv) export(searchZeros) S3method(print,test.nleqslv) nleqslv/NEWS0000644000175100001440000002425113127110607012455 0ustar hornikusers3.3.1 o better comments in Fortran source and some reorganization of code o simplification QR update subroutines o documentation tweaks 3.3 o prevent possible intermediate NaN's in cubic linesearch o test for NaN's in x-vector supplied to user function while iterating o documentation tweaks for searchZeros o more accurate error messags for non-finite arguments passed to user jacobian function 3.2 o more precise error checking in nleqslv.c (bug) 3.1 o register native routines in dll 3.0.3 o allow scalar user supplied derivative for a scalar function. (avoid error message about jacobian not being a matrix) (bug) o documentation tweaks 3.0.2 o display inverse condition of Jacobian in "ill-conditioned" message in the return value of nleqslv o documentation tweaks 3.0.1 o removed item Tcnt from the return value of testnslv. In the case of a banded jacobian the value was incorrect (bug). o corrected faulty error message (bug) o code and documentation tweaks 3.0 o documentation tweaks o check length of initial estimates to avoid Lapack error messages (bug) o check number of rows of matrix in searchZeros (bug) o check correctly that user supplied jacobian function is actually a function (bug) o searchZeros now uses try with silent=TRUE o searchZeros returns additional indices providing more information about bad/invalid initial estimates 2.9.1 o strict validity test of control argument o documentation tweaks 2.9 o added searchZeros function to search for zeros given a matrix of initial points 2.8 o added a column to the testnslv output giving the total number of function evaluations if a numerical jacobian was requested o corrected bug in testnslv when termination code > 6 o added test for completely singular jacobian when allowSingular==TRUE (the Levenberg-Marquardt correction will not work in such a situation) (detected with a system of equations made by Ravi Varadhan) o changed columnheaders of dataframe generated by testnslv (sorry about that) o added a width.cutoff argument to the printing of an object returned by testnslv to restrict the length of the call display o added a check of testnslv in tests 2.7 o reintroduced the Levenberg-Marquardt correction for ill-conditioned or singular jacobians. It now works as desired. 2.6 o display a marker in the trust region iteration report when a trial step will be taken o better documentation of the iteration reports o added input and output files used for the documentation of the iterations reports in a subdirectory of directory inst o more detailed comments in several source files o spelling 2.5 o corrected nasty bug in cubic linesearch. Use Higham procedure to calculate roots of a quadratic accurately. The correct test of the shape of a quadratic is the sign of the coefficient of x^2 and not a test involving the discriminant. Some results may change. o corrected package name typo (reported by Kurt Hornik) o minor changes in documentation 2.4 o Dennis-Schnabel hookstep added as global strategy "hook" o testnslv adjusted for new extra global strategy o removed all trailing spaces from files (added in by editor) 2.3.1 o allow strings "cauchy" and "newton" in control$delta argument o documentation for iteration report fixed o better comments trial steps when updating trust region 2.3 o clarified documentation for iteration report o removed redundant fortran code o modified nwclsh.f to avoid ftnchek warnings o use Lapack dlacpy to copy upper triangular part of a QR decomposition o modified some fortran code for easier conversion with f2f to fortran 95 o modified nwnleq and brsolv to split rjac into Q and R at higher level (avoids some ftnchek warnings) o update package date in DESCRIPTION 2.2 o introduce a function to test and optionally benchmark different methods and global strategies and print results compactly o added a new global strategy: cubic line search o try to safeguard against very large trust region in iteration report o allocate half as much memory for the Jacobian when Newton method is specfied o advice in error message on what to do when initial value of function is not finite o cleanup some code 2.1.1 o corrected tiny rounding error when computing banded jacobian (fdjac2 in src/nwutil.f) o corrected error in documentation of iteration report o cleanup fortran sources to remove many (not all) ftnchek warnings o clarifications in the documentation 2.1 o introduced an option to specify that the jacobian is banded o if the initial parameter vector has a names attribute, the parameter vector passed to the function to solve will have these names as attribute o corrected another bug when checking a user supplied jacobian: scaled x-values were being returned o use Rinternals.h instead of Rdefines.h o replace C++ style comments o cleanup/simplification of C code in nleqslv.c and more error checking 2.0 o introduced an option to return the final (approximated) jacobian o corrected horrible bug when checking analytical jacobian with scaled x-values (checking incorrectly reported an incorrect jacobian) o strict checking of return value of user supplied Jacobian function. Jacobian must be a numerical matrix of correct dimensions. o if the initial parameter vector has an attribute names the output parameter vector will have these names as attribute o more tests of Newton method o (internal) comments in some fortran to provide clarification o (internal) reorganized fortran for less duplication of code o No longer use qrupdate routines for updating QR. Use heavily modified version of Dennis+Schnabel. Change has no effect on results (at least in all my tests). 1.9.4 o checking validity of a user supplied jacobian is no longer done before the first iteration in order to avoid computing initial jacobian twice. The checks are now done after the return of the user supplied jacobian; this provides more safety. o introduced a tolerance parameter for testing for an ill-conditioned jacobian or broyden approximation. The default tolerance is now equal to 1e-12 and not the machine precison. o added an item to the outputlist of nleqslv giving the number of (outer) iterations used. o better description of the meaning of the number of function evaluations in the return value. 1.9.3 o use QR update routines from opensource library qrupdate. The changes should have no effect on results. o internal change in brsolv: use a different larger workspace for brupdt to accomodate different QR updating routines which need a larger workspace o moved subroutine for query of Lapack dgeqrf of optimal size of work array to lautil.f (where it belongs). Changed name to liqsiz. 1.9.2 o made calculation of jacobian when checking user supplied jacobian identical to how calculation of numerical jacobian is done o non finite values in function values when computing numerical derivatives always result in a fatal error o added link to iteration report in the description of trace=1 o corrected several small irregularities in the documentation 1.9.1 o removed all Fortran internal write statements to avoid R check warnings o improved output of possible errors by check jacobian o added error message for jacobian error in manual o mention Lapack condition estimator in documentation of iteration report 1.9.0 o added a pure Newton or Broyden without global strategy o use useDynLib in NAMESPACE instead of .onLoad 1.8.6 o added NAMESPACE and changed to use .onLoad function o removed gamma from iteration report (doesn't provide useful info; eta is sufficient) o minor internal reorganization of code o improved documentation of the iteration report 1.8.5 o remove unused variables from Fortran code (thanks to Kurt Hornik for pointing this out). o improved comments in nwout.c o avoid use of sprintf for print in E-format since on Windows (at least some) three digits are used by default for the exponent even when two suffice. That messes up layout of detailed iteration report. Use Rprintf. 1.8.4 o remove unused variables in C function nleqslv. o tests now only check if a solution has been found with a specified tolerance and avoid explicit floating point output. o corrected small errors in manual. 1.8.3 o nicer output when control argument contains invalid names. o some examples are now not run by default to avoid problems (bus error) on PowerPC Mac OS X; I cannot test. 1.8.2 o Added code to copy initial values to final values in case of bad jacobian. 1.8.1 o cleanup checking of control argument. o modified tests/brdban.R and tests/chquad.R to be more robust against small rounding differences. 1.8 o internally scaled x-values are now used instead of scaling/unscaling of various vectors whenever/wherever required. This makes the code much cleaner and easier to maintain. Therefore the jacobian matrix used in the code is now scaled. The reported condition number will be different. o added forgotten integer declaration in nwtcvg (nwutil.for). o corrected documentation errors. 1.7 o negative values for stepmax (maximum stepsize) now imply no maximum stepsize. The default for stepmax (maximum stepsize) -1.0 so there is no maximum stepsize. o removed the Levenberg-Marquardt correction for ill-conditioned or singular jacobians. The correction hardly ever gave sensible results. The algorithm now returns an error condition when a Jacobian is singular or ill-conditioned. 1.6.1 o fixed several incomplete last lines. 1.6 o corrected initialization bug. o corrected parameter error for Cauchy start in examples. o code cleaning to get rid of fortran statement labels. 1.5 o corrected missing/superfluous closing brackets in nleqslv.Rd. 1.4 o correct horrible bug caused by typo in nwnwtn causing dgeqrf to be called with an absurd value for the lwork argument. Typical fortran problem. 1.3 o use blocked Lapack QR routines. Significant speed increase for larger n (500+) in most cases. 1.2 o corrected wrong name for the flag for checking an analytical jacobian in nleqslv.R and the documentation. 1.1 o the default initial trust region size is now set to the length of the Newton step. o corrected various errors in the documentation * the termination codes were a muddle. * several elements of the return list were incorrectly named in the documentation. 1.0 o initial version nleqslv/R/0000755000175100001440000000000012572112020012145 5ustar hornikusersnleqslv/R/searchzeros.R0000644000175100001440000000464612635740613014651 0ustar hornikuserssearchZeros <- function(x, fn, digits=4L, ... ) { if( !is.numeric(x) ) stop('argument x should be numeric') if( !is.matrix(x) ) stop('argument x must be a matrix') if( any(is.na(x)) ) stop("argument x may not contain NA") if( !is.numeric(digits) ) stop('argument digits should be numeric') if( is.na(digits) ) digits <- 4L N <- nrow(x) if( N < 1 ) stop("Matrix 'x' must have at least 1 row") tcode <- numeric(N) fnorm <- numeric(N) xmat <- matrix(NA, nrow=N, ncol=ncol(x)) kerr <- numeric(N) kptr <- 0 # for k==1 check that all arguments are correct --> no try for ( k in seq_len(N) ){ if( k == 1 ) { z <- nleqslv(x[k, ], fn=fn, ...) } else { z <- try(nleqslv(x[k, ], fn=fn, ...), silent=TRUE) if( inherits(z, "try-error") ) { kptr <- kptr+1 kerr[kptr] <- k next } } tcode[k] <- z$termcd fnorm[k] <- norm(z$fvec,"2")^2/2 # criterion for global methods xmat[k, ] <- z$x } # locate index of converged trials and store corresponding starting values # return NULL if no full convergence obtained if(!any(tcode==1)) return(NULL) idxcvg <- which(tcode==1) xstartcvg <- x[idxcvg,,drop=FALSE] # rounded solutions for locating duplicates and remove duplicates xsol <- round(xmat[idxcvg,,drop=FALSE], digits) notdups <- !duplicated(xsol) xsol <- xsol[notdups,,drop=FALSE] solstart <- xstartcvg[notdups,,drop=FALSE] if( !is.null(colnames(x)) ) { colnames(xmat) <- colnames(x) colnames(xsol) <- colnames(x) colnames(solstart) <- colnames(x) } # order the rounded solution if( nrow(xsol) > 1 ) { zidxo <- do.call(order,split(xsol,col(xsol))) } else { zidxo <- 1 } idxfatal <- if(kptr) kerr[1:kptr] else integer(0) idxxtol <- which(tcode==2) idxnocvg <- which(tcode>2) # original unrounded solutions with duplicates (above) removed xsol <- xmat[idxcvg,,drop=FALSE][notdups,,drop=FALSE] # return full precision solutions ordered with rounded ordering res <- list(x=xsol[zidxo,,drop=FALSE], xfnorm=fnorm[idxcvg][notdups][zidxo], fnorm=fnorm[idxcvg], idxcvg=idxcvg, idxxtol=idxxtol, idxnocvg=idxnocvg, idxfatal=idxfatal, xstart=solstart[zidxo,,drop=FALSE],cvgstart=xstartcvg) res } nleqslv/R/testnslv.R0000644000175100001440000000755512707127627014211 0ustar hornikusers testnslv <- function(x, fn, jac=NULL, ..., method=c("Newton", "Broyden"), global=c("cline", "qline", "gline", "pwldog", "dbldog", "hook", "none"), Nrep=0L, title=NULL ) { # utility functions catmsg <- function(m,g,res) { cat(sprintf("Error (method=%s global=%s): %s\n",m,g,attr(res,"condition")$message)) } makeerrlist <- function(m,g,cpusecs=NULL) { if(is.null(cpusecs)) { z <- list(Method=m, Global=g, termcd=NA, Fcnt=NA, Jcnt=NA, Iter=NA, Message="ERROR",Fnorm=NA) } else { z <- list(Method=m, Global=g, termcd=NA, Fcnt=NA, Jcnt=NA, Iter=NA, Message="ERROR",Fnorm=NA, cpusecs=cpusecs) } z } makereslist <- function(m,g,res,cpusecs=NULL) { fnorm <- sum(res$fvec^2)/2 # necessary to test for termcd<0 and >6 otherwise R errors later in output # see R-help about switch if(res$termcd < 0 ) stop("User supplied jacobian most likely incorrect: cannot continue") else if(res$termcd > 7 ) message <- "BADCD" else message <- switch(res$termcd, "Fcrit", "Xcrit", "Stalled", "Maxiter", "Illcond", "Singular", "BadJac") if(is.null(cpusecs)) { z <- list(Method=m, Global=g, termcd=res$termcd, Fcnt=res$nfcnt, Jcnt=res$njcnt, Iter=res$iter, Message=message, Fnorm=fnorm) } else { z <- list(Method=m, Global=g, termcd=res$termcd, Fcnt=res$nfcnt, Jcnt=res$njcnt, Iter=res$iter, Message=message, Fnorm=fnorm, cpusecs=cpusecs) } z } methods <- match.arg(method, c("Newton", "Broyden"), several.ok=TRUE) globals <- match.arg(global, c("cline", "qline", "gline", "pwldog", "dbldog", "hook", "none"), several.ok=TRUE) my.call <- match.call() reslist <- vector("list", length(methods)*length(globals)) # use try to avoid process stopping for Jacobian with non-finite values # if that happens, go to next method/global # avoidable fatal user errors will also lead to useless next method/global idx <- 1 for(m in methods) for(g in globals) { if( Nrep >= 1) { mytime <- system.time( for(k in seq_len(Nrep)) { res <- try(nleqslv(x, fn, jac, ..., method=m, global=g), silent=TRUE) if(inherits(res,"try-error")) break }, gcFirst = FALSE) cpus <- mytime[3] } else { res <- try(nleqslv(x, fn, jac, ..., method=m, global=g),silent=TRUE) cpus <- NULL } if(inherits(res,"try-error")) { catmsg(m,g,res) z <- makeerrlist(m,g,cpus) } else { z <- makereslist(m,g,res,cpus) } reslist[[idx]] <- z idx <- idx+1 } # from http://stackoverflow.com/questions/4512465/what-is-the-most-efficient-way-to-cast-a-list-as-a-data-frame?rq=1 ## @Martin Morgan's Map() sapply() solution: f <- function(x) function(i) sapply(x, `[[`, i) z <- as.data.frame(Map(f(reslist), names(reslist[[1]])), stringsAsFactors=FALSE) res <- list() res$out <- z res$call <- my.call res$title <- title class(res) <- "test.nleqslv" res } print.test.nleqslv <- function(x, digits=4, width.cutoff=45L, ...) { if(!inherits(x, "test.nleqslv")) stop("method is only for test.nleqslv objects") # calculate total number of function evaluations if numeric jacobian used cat("Call:\n",paste0(deparse(x$call, width.cutoff=width.cutoff), collapse = "\n"), "\n\n", sep = "") if(is.null(x$title)) cat("Results:\n") else cat("Results: ",x$title,"\n", sep="") print(x$out, digits=digits,...) invisible(x) } nleqslv/R/nleqslv.R0000644000175100001440000000461513117761435014002 0ustar hornikusers# # Interface to Fortran library for solving a system of nonlinear equations # with either a Broyden or a full Newton method # There a six global search methods: # cubic, quadratic and geometric linesearch # double dogleg trust region a la Dennis Schnabel # powell single dogleg a la Minpack # so-called hook step (Levenberg-Marquardt) # nleqslv <- function(x, fn, jac = NULL, ..., method = c("Broyden", "Newton"), global = c("dbldog", "pwldog", "cline", "qline", "gline", "hook", "none"), xscalm = c("fixed","auto"), jacobian=FALSE, control = list()) { fn1 <- function(par) fn(par, ...) if( is.null(jac ) ) { jacfunc <- NULL } else { if(!is.function(jac)) stop("argument 'jac' is not a function!") jacfunc <- function(par) jac(par, ...) } method <- match.arg(method) global <- match.arg(global) xscalm <- match.arg(xscalm) ## Defaults con <- list(ftol=1e-8, xtol=1e-8, btol=1e-3, stepmax=-1.0, delta="newton", sigma=0.5, scalex = rep(1, length(x)), maxit=150, trace=0, chkjac=FALSE, cndtol=1e-12, allowSingular=FALSE, dsub=-1L, dsuper=-1L ) # limit maximum number of iterations for pure local strategy if( global == "none" ) con$maxit=20 # strict validity test of control # based on test of control argument in nlminb if( length(control) ) { namc <- names(control) if( !is.list(control) || is.null(namc) ) stop("'control' argument must be a named list") # check names of control argument if( !all(namc %in% names(con)) ) stop("unknown names in control: ", paste(sQuote(namc[!(namc %in% names(con))]), collapse=", ")) con[namc] <- control } tmp <- con[["delta"]] if( is.character(tmp) ) { k <- match(tolower(tmp), c("cauchy","newton")) con[["delta"]] <- as.numeric(-k) } else if( !is.numeric(tmp) ) stop('control["delta"] should be either character or numeric') # to reset flag for checking recursive calls (not allowed for now) on.exit(.C(C_deactivatenleq)) out <- .Call(C_nleqslv, x, fn1, jacfunc, method, global, xscalm, jacobian, con, new.env()) out } nleqslv/MD50000644000175100001440000001401613127410453012266 0ustar hornikusersabcaaf071cf8387a92ccc15cfc80c285 *DESCRIPTION de8ab13c7cefd5014e9a71517a07c547 *NAMESPACE 81eedbecc8294996b38879d356de088f *NEWS 1ce28b9e3f2747aafe8fa96d4f1d069b *R/nleqslv.R 46e850d267885e5d388d2b1afdda5d29 *R/searchzeros.R 11bd8df056de39ac1a96c342b0f1656c *R/testnslv.R d83d9760570892edbd870bdfd7159284 *inst/iterationreport/00readme.txt 591a0cf58669fdef0daffaa577b91188 *inst/iterationreport/dsdbldog.R 4b8adf76b4be390b21f293e28e410637 *inst/iterationreport/dsdbldog.Rout f260671fa8bdaac217237462c678dbf9 *inst/iterationreport/dsdbldog.Rout.txt 641ff52a9704408d0fcfb934f26c77b1 *inst/iterationreport/dshook.R dce68612a2db2b2ab3b5ef8b6721b861 *inst/iterationreport/dshook.Rout d91dfde5224d5f1f5e59147eeb82aecb *inst/iterationreport/dshook.Rout.txt 640e340dbc006b9f1b29370baaa7f129 *inst/iterationreport/dslnsrch.R 18b019466b5bb39b4a78d53ff135d111 *inst/iterationreport/dslnsrch.Rout 68bb5c0ddae17d906db209ae972a2d43 *inst/iterationreport/dslnsrch.Rout.txt 8793ec6d457341a864e62d929efb18eb *inst/iterationreport/dspure.R 0961b47072cb6849a3a90262150ed5a7 *inst/iterationreport/dspure.Rout e93eba5f1640e0cbe7521cd7c05f6b6c *inst/iterationreport/dspure.Rout.txt 8d8fab0912a8002eb55d6c8dbe6432fb *inst/iterationreport/dspwldog.R 59cd081725a1294ceaeac776c4dca271 *inst/iterationreport/dspwldog.Rout 84af886c99be7561dae7d5e490796b81 *inst/iterationreport/dspwldog.Rout.txt d82b60e6e9615ce348f82cddb64433a1 *man/nleqslv-package.Rd d6b6400debdec11bcb27b7af42234cee *man/nleqslv.Rd 3daad4ddd6cbf326478a613c86c93015 *man/print.testnslv.Rd cfa67a05abdeb8e1aca25e409ac6ed85 *man/searchzeros.Rd a291e7c0ef44985835aa9856764783ad *man/testnslv.Rd 9290ebb081a2f9def80826a6555f3fb6 *man/zznleqslv-iterationreport.Rd 1ed18cd8f15e511a405098ea1e6cc224 *src/Makevars e434ac6b1d756f2e2be614f8c0762071 *src/init.c d0778920b083eb3157775476af780c62 *src/lautil.f adbe16b0f0703e1cca12061c7426388b *src/limhpar.f 1093a009194af2ab7a90f3fc604ffe82 *src/liqrev.f 8487fc1caf0589858886d6c3674bdb93 *src/liqrup.f d83a0b755fccf6fa9bd593fe73a24514 *src/lirslv.f 0f5eeace374fa1b2d2791919a773d7a0 *src/nleqslv.c 39aa2bee1e689c9a1d9ad427a2996c9a *src/nwbjac.f 006767c20f9b38cea482779c3b98caf5 *src/nwbrdn.f 4356bb6143a112fbd08af084cae5249f *src/nwclsh.f 91225b7618a9de81260b3992ce9e48fc *src/nwddlg.f 1fdfc01ee9482bddab455ec464fa0f1f *src/nwglsh.f 49c20de17d7977ce6929ffe48ea7aa16 *src/nwmhlm.f 90835cab5fff0a3f28bc86f5ec9fdb09 *src/nwnjac.f 3f4e8f353fbd7f4a44f94a918dd4c2b1 *src/nwnleq.f 0863974b1e5678439edacc545d66d9c2 *src/nwnwtn.f 3d1781591d54d8325c888b7309335f88 *src/nwout.c 5e4ef134bf4864e1f0f5a7b436ca3c60 *src/nwpdlg.f 3635901d16a6773f2736796b1b63d977 *src/nwpure.f 62c658d38a581a947bbe710e2a76a1cc *src/nwqlsh.f 4007f86427390c2d7bcebaf65fcf688b *src/nwtrup.f e4236f110e2aad1093ae638065fc3c2b *src/nwutil.f 368145c17dea673fcce9e3de7a9c46ec *tests/brdban.R 1b92b0b4a8877d51c098cb8a17dd0a11 *tests/brdban.Rout 1b92b0b4a8877d51c098cb8a17dd0a11 *tests/brdban.Rout.save dce56d1f0fb6be677d822c03a1c7090c *tests/brdbanded.R cd2e02c0d85998835af9e49d929d185e *tests/brdbanded.Rout cd2e02c0d85998835af9e49d929d185e *tests/brdbanded.Rout.save e3724551bf410d8b6c772a3fda2f9bff *tests/brdtri.R 661f77c3b241c28460ee7d5bc2d3c5a1 *tests/brdtri.Rout 661f77c3b241c28460ee7d5bc2d3c5a1 *tests/brdtri.Rout.save d31b1b6a8daa6b4529999c05642516ea *tests/brdtrijac.R e7f8008a49b30c722e162124883feae3 *tests/brdtrijac.Rout e7f8008a49b30c722e162124883feae3 *tests/brdtrijac.Rout.save d11517ec72ec7d298ee1a505c7bbacb5 *tests/chquad.R b2b5bdfeab786db8dfb87cb15e3413c3 *tests/chquad.Rout b2b5bdfeab786db8dfb87cb15e3413c3 *tests/chquad.Rout.save 973ab85590b38c9a9226712531e23cef *tests/control-try.R 852461e62cb48ef5b41bb7b1af25f4da *tests/control-try.Rout.save 50bb14fcb02568a0a472e3a6b25e5a64 *tests/dslnex.R 553b02e76681b88536dcd87a009ad0cb *tests/dslnex.Rout 553b02e76681b88536dcd87a009ad0cb *tests/dslnex.Rout.save 2a740ea725de32d8f4b647a94a0cabe3 *tests/dslnexCN.R 320bd1466a381904a266ed2ba8330c03 *tests/dslnexCN.Rout 320bd1466a381904a266ed2ba8330c03 *tests/dslnexCN.Rout.save 4180518cbd6ed5bb8643256d79f0ad73 *tests/dslnexHook.R 7defc1e3be32b39f1d91a491946cfdf0 *tests/dslnexHook.Rout 7defc1e3be32b39f1d91a491946cfdf0 *tests/dslnexHook.Rout.save 53d6475959ab5d00664dd298f4b8cb6b *tests/dslnexauto.R 5caa2468eb3f9c0adfc7665b57553ddf *tests/dslnexauto.Rout 5caa2468eb3f9c0adfc7665b57553ddf *tests/dslnexauto.Rout.save 36d3ada77260d985f4d1a9059d0fdb18 *tests/dslnexjacout.R 817051c9e1fbef970660b0300eeaf1e6 *tests/dslnexjacout.Rout 817051c9e1fbef970660b0300eeaf1e6 *tests/dslnexjacout.Rout.save f947f9b7a322f5613fe0368bb3502b1e *tests/dslnexscaled.R 4b87b64ecafba8e9cd0ccca736a8ad3f *tests/dslnexscaled.Rout 4b87b64ecafba8e9cd0ccca736a8ad3f *tests/dslnexscaled.Rout.save 99ea5bd71b0ed140cf8e9646aa030285 *tests/singular1.R 2ee66404d95e15481593d02a34fd21df *tests/singular1.Rout 2ee66404d95e15481593d02a34fd21df *tests/singular1.Rout.save f64ed3d70411778ff401bbb0bd971eca *tests/singular2.R 77b1529311cfd77230c8bfdf91e386f9 *tests/singular2.Rout 77b1529311cfd77230c8bfdf91e386f9 *tests/singular2.Rout.save 041949270d6654751682e162afe6d499 *tests/singular3.R 7573eae78b0bed636c21d783b4d0bb09 *tests/singular3.Rout 2de2d3d3f164456a69409b397ce1a2c7 *tests/singular3.Rout.save 10b302612369be6b1a79ddd840372e84 *tests/trig.R fa2f21ae5b939656b511c6a607501006 *tests/trig.Rout fa2f21ae5b939656b511c6a607501006 *tests/trig.Rout.save a611c0dbc906e030df5c492c8e67099c *tests/tscalargrad.R 3f6d029955437e8ad756700c6d6498b9 *tests/tscalargrad.Rout.save def7eacef89c7d7f2fa3fe86b2446dd3 *tests/xcutlip1p2.R fff5000fc4fbf5a274566e5303d7d17f *tests/xcutlip1p2.Rout fff5000fc4fbf5a274566e5303d7d17f *tests/xcutlip1p2.Rout.save 158fda4c71941217d8e103c1cc226a15 *tests/xnames.R d683267facc948825e43c369996a234d *tests/xnames.Rout d683267facc948825e43c369996a234d *tests/xnames.Rout.save 3e391b54bac8010ed266358aa27db16e *tests/xsearchzeros.R 3419b95a27623e48fc92d59c3ad938f8 *tests/xsearchzeros.Rout 3419b95a27623e48fc92d59c3ad938f8 *tests/xsearchzeros.Rout.save d813f02c8815c5514474ed38f63978da *tests/xtestnslv.R a1acd0befd617fc69d731fc55a29b478 *tests/xtestnslv.Rout a1acd0befd617fc69d731fc55a29b478 *tests/xtestnslv.Rout.save nleqslv/DESCRIPTION0000644000175100001440000000130313127410453013457 0ustar hornikusersPackage: nleqslv Type: Package Title: Solve Systems of Nonlinear Equations Version: 3.3.1 Date: 2017-07-06 Author: Berend Hasselman Maintainer: Berend Hasselman Description: Solve a system of nonlinear equations using a Broyden or a Newton method with a choice of global strategies such as line search and trust region. There are options for using a numerical or user supplied Jacobian, for specifying a banded numerical Jacobian and for allowing a singular or ill-conditioned Jacobian. License: GPL (>= 2) NeedsCompilation: yes Packaged: 2017-07-05 09:43:30 UTC; berendhasselman Repository: CRAN Date/Publication: 2017-07-06 10:30:03 UTC nleqslv/man/0000755000175100001440000000000012725614155012537 5ustar hornikusersnleqslv/man/searchzeros.Rd0000644000175100001440000001065213107026075015353 0ustar hornikusers\name{searchZeros} \alias{searchZeros} \encoding{UTF-8} \title{Solve a nonlinear equation system with multiple roots from multiple initial estimates} \description{This function solves a system of nonlinear equations with \code{nleqlsv} for multiple initial estimates of the roots. } \usage{ searchZeros(x, fn, digits=4, ... ) } \arguments{ \item{x}{A matrix with each row containing an initial guess of the roots.} \item{fn}{A function of \code{x} returning a vector of function values with the same length as the vector \code{x}.} \item{digits}{integer passed to \code{\link{round}} for locating and removing duplicate rounded solutions.} \item{\dots}{Further arguments to be passed to \code{\link{nleqslv}}, \code{fn} and \code{jac}.} } \details{ Each row of \code{x} is a vector of initial estimates for the argument \code{x} of \code{nleqslv}. The function runs \code{nleqslv} for each row of the matrix \code{x}. The first initial value is treated separately and slightly differently from the other initial estimates. It is used to check if all arguments in \code{...} are valid arguments for \code{nleqslv} and the function to be solved. This is done by running \code{nleqslv} with no condition handling. If an error is then detected an error message is issued and the function stops. For the remaining initial estimates \code{nleqslv} is executed silently. Only solutions for which the \code{nleqslv} termination code \code{tcode} equals \code{1} are regarded as valid solutions. The rounded solutions (after removal of duplicates) are used to order the solutions in increasing order. These rounded solutions are not included in the return value of the function. } \value{ If no solutions are found \code{NULL} is returned. Otherwise a list containing the following components is returned \describe{ \item{\code{x}}{a matrix with each row containing a unique solution (unrounded)} \item{\code{xfnorm}}{a vector of the function criterion associated with each row of the solution matrix \code{x}.} \item{\code{fnorm}}{a vector containing the function criterion for every converged result} \item{\code{idxcvg}}{a vector containing the row indices of the matrix of initial estimates for which function value convergence was achieved} \item{\code{idxxtol}}{a vector containing the row indices of the matrix of initial estimates for which x-value convergence was achieved} \item{\code{idxnocvg}}{a vector containing the row indices of the matrix of initial estimates which lead to an \code{nleqslv} termination code > 2} \item{\code{idxfatal}}{a vector containing the row indices of the matrix of initial estimates for which a fatal error occurred that made \code{nleqslv} stop} \item{\code{xstart}}{a matrix of the initial estimates corresponding to the solution matrix} \item{\code{cvgstart}}{a matrix of all initial estimates for which convergence was achieved} } } %\note{ %} % %\section{Warning}{You cannot use this function recursively. %Thus function \code{fn} should not in its turn call \code{nleqslv}. %} % %\seealso{\code{\link{"BB"}}} % \examples{ # Dennis Schnabel example 6.5.1 page 149 (two solutions) set.seed(123) dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } xstart <- matrix(runif(50, min=-2, max=2),ncol=2) ans <- searchZeros(xstart,dslnex, method="Broyden",global="dbldog") ans # more complicated example # R. Baker Kearfott, Some tests of Generalized Bisection, # ACM Transactions on Methematical Software, Vol. 13, No. 3, 1987, pp 197-220 # A high-degree polynomial system (section 4.3 Problem 12) # There are 12 real roots (and 126 complex roots to this system!) hdp <- function(x) { f <- numeric(length(x)) f[1] <- 5 * x[1]^9 - 6 * x[1]^5 * x[2]^2 + x[1] * x[2]^4 + 2 * x[1] * x[3] f[2] <- -2 * x[1]^6 * x[2] + 2 * x[1]^2 * x[2]^3 + 2 * x[2] * x[3] f[3] <- x[1]^2 + x[2]^2 - 0.265625 f } N <- 40 # at least to find all 12 roots set.seed(123) xstart <- matrix(runif(3*N,min=-1,max=1), N, 3) # N initial guesses, each of length 3 ans <- searchZeros(xstart,hdp, method="Broyden",global="dbldog") ans$x } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{nonlinear} \keyword{optimize} nleqslv/man/nleqslv.Rd0000644000175100001440000004454713127110607014516 0ustar hornikusers\name{nleqslv} \alias{nleqslv} \encoding{UTF-8} \title{Solving systems of nonlinear equations with Broyden or Newton} \description{ The function solves a system of nonlinear equations with either a Broyden or a full Newton method. It provides line search and trust region global strategies for difficult systems. } \usage{ nleqslv(x, fn, jac=NULL, ..., method = c("Broyden", "Newton"), global = c("dbldog", "pwldog", "cline", "qline", "gline", "hook", "none"), xscalm = c("fixed","auto"), jacobian=FALSE, control = list() ) } \arguments{ \item{x}{A numeric vector with an initial guess of the root of the function.} \item{fn}{A function of \code{x} returning a vector of function values with the same length as the vector \code{x}.} \item{jac}{A function to return the Jacobian for the \code{fn} function. For a vector valued function \code{fn} the Jacobian must be a numeric matrix of the correct dimensions. For a scalar valued function \code{fn} the \code{jac} function may return a scalar. If not supplied numerical derivatives will be used.} \item{\dots}{Further arguments to be passed to \code{fn} and \code{jac}.} \item{method}{The method to use for finding a solution. See \sQuote{Details}.} \item{global}{The global strategy to apply. See \sQuote{Details}.} \item{xscalm}{The type of x scaling to use. See \sQuote{Details}.} \item{jacobian}{A logical indicating if the estimated (approximate) jacobian in the solution should be returned. See \sQuote{Details}.} \item{control}{A named list of control parameters. See \sQuote{Details}.} } \details{ The algorithms implemented in \code{nleqslv} are based on Dennis and Schnabel (1996). \subsection{Methods}{ Method \code{Broyden} starts with a computed Jacobian of the function and then updates this Jacobian after each successful iteration using the so-called Broyden update. This method often shows super linear convergence towards a solution. When \code{nleqslv} determines that it cannot continue with the current Broyden matrix it will compute a new Jacobian. Method \code{Newton} calculates a Jacobian of the function \code{fn} at each iteration. Close to a solution this method will usually show quadratic convergence. Both methods apply a so-called (backtracking) global strategy to find a better (more acceptable) iterate. The function criterion used by the algorithm is half of the sum of squares of the function values and \dQuote{acceptable} means sufficient decrease of the current function criterion value compared to that of the previous iteration. A comprehensive discussion of these issues can be found in Dennis and Schnabel (1996). Both methods apply an unpivoted QR-decomposition to the Jacobian as implemented in Lapack. The Broyden method applies a rank-1 update to the Jacobian at the end of each iteration and is based on a simplified and modernized version of the algorithm described in Reichel and Gragg (1990). } \subsection{Global strategies}{ When applying a full Newton or Broyden step does not yield a sufficiently smaller function criterion value \code{nleqslv} will attempt to decrease the steplength using one of several so-called global strategies. The \code{global} argument indicates which global strategy to use or to use no global strategy \describe{ \item{\code{cline}}{a cubic line search} \item{\code{qline}}{a quadratic line search} \item{\code{gline}}{a geometric line search} \item{\code{dbldog}}{a trust region method using the double dogleg method as described in Dennis and Schnabel (1996)} \item{\code{pwldog}}{a trust region method using the Powell dogleg method as developed by Powell (1970).} \item{\code{hook}}{a trust region method described by Dennis and Schnabel (1996) as \emph{The locally constrained optimal (\dQuote{hook}) step}. It is equivalent to a Levenberg-Marquardt algorithm as described in \enc{Moré}{More} (1978) and Nocedal and Wright (2006).} \item{\code{none}}{Only a pure local Newton or Broyden iteration is used. The maximum stepsize (see below) is taken into account. The default maximum number of iterations (see below) is set to 20.} } The double dogleg method is the default global strategy employed by this package. Which global strategy to use in a particular situation is a matter of trial and error. When one of the trust region methods fails, one of the line search strategies should be tried. Sometimes a trust region will work and sometimes a line search method; neither has a clear advantage but in many cases the double dogleg method works quite well. When the function to be solved returns non-finite function values for a parameter vector \code{x} and the algorithm is \emph{not} evaluating a numerical Jacobian, then any non-finite values will be replaced by a large number forcing the algorithm to backtrack, i.e. decrease the line search factor or decrease the trust region radius. } \subsection{Scaling}{ The elements of vector \code{x} may be scaled during the search for a zero of \code{fn}. The \code{xscalm} argument provides two possibilities for scaling \describe{ \item{\code{fixed}}{the scaling factors are set to the values supplied in the \code{control} argument and remain unchanged during the iterations. The scaling factor of any element of \code{x} should be set to the inverse of the typical value of that element of \code{x}, ensuring that all elements of \code{x} are approximately equal in size.} \item{\code{auto}}{the scaling factors are calculated from the euclidean norms of the columns of the Jacobian matrix. When a new Jacobian is computed, the scaling values will be set to the euclidean norm of the corresponding column if that is larger than the current scaling value. Thus the scaling values will not decrease during the iteration. This is the method described in \enc{Moré}{More} (1978). Usually manual scaling is preferable.} } } \subsection{Jacobian}{ When evaluating a numerical Jacobian, an error message will be issued on detecting non-finite function values. An error message will also be issued when a user supplied jacobian contains non-finite entries. When the \code{jacobian} argument is set to \code{TRUE} the final Jacobian or Broyden matrix will be returned in the return list. The default value is \code{FALSE}; i.e. to not return the final matrix. There is no guarantee that the final Broyden matrix resembles the actual Jacobian. The package can cope with a singular or ill-conditioned Jacobian if needed by setting the \code{allowSingular} component of the \code{control} argument. The method used is described in Dennis and Schnabel (1996); it is equivalent to a Levenberg-Marquardt type adjustment with a small damping factor. \emph{There is no guarantee that this method will be successful.} Warning: \emph{\code{nleqslv} may report spurious convergence in this case.} By default \code{nleqslv} returns an error if a Jacobian becomes singular or very ill-conditioned. A Jacobian is considered to be very ill-conditioned when the estimated inverse condition is less than or equal to a specified tolerance with a default value equal to \eqn{10^{-12}}{1e-12}; this can be changed and made smaller with the \code{cndtol} item of the \code{control} argument. \emph{There is no guarantee that any change will be effective.} } \subsection{Control options}{ The \code{control} argument is a named list that can supply any of the following components: \describe{ \item{\code{xtol}}{The relative steplength tolerance. When the relative steplength of all scaled x values is smaller than this value convergence is declared. The default value is \eqn{10^{-8}}{1e-8}. } \item{\code{ftol}}{The function value tolerance. Convergence is declared when the largest absolute function value is smaller than \code{ftol}. The default value is \eqn{10^{-8}}{1e-8}. } \item{\code{btol}}{The backtracking tolerance. When the relative steplength in a backtracking step to find an acceptable point is smaller than the backtracking tolerance, the backtracking is terminated. In the \code{Broyden} method a new Jacobian will be calculated if the Jacobian is outdated. The default value is \eqn{10^{-3}}{1e-3}. } \item{\code{cndtol}}{The tolerance of the test for ill conditioning of the Jacobian or Broyden approximation. If less than the machine precision it will be silently set to the machine precision. When the estimated inverse condition of the (approximated) Jacobian matrix is less than or equal to the value of \code{cndtol} the matrix is deemed to be ill-conditioned, in which case an error will be reported if the \code{allowSingular} component is set to \code{FALSE}. The default value is \eqn{10^{-12}}{1e-12}. } \item{\code{sigma}}{Reduction factor for the geometric line search. The default value is 0.5.} \item{\code{scalex}}{a vector of scaling values for the parameters. The inverse of a scale value is an indication of the size of a parameter. The default value is 1.0 for all scale values.} \item{\code{maxit}}{The maximum number of major iterations. The default value is 150 if a global strategy has been specified. If no global strategy has been specified the default is 20.} \item{\code{trace}}{Non-negative integer. A value of 1 will give a detailed report of the progress of the iteration. For a description see \code{\link{Iteration report}}.} \item{\code{chkjac}}{A logical value indicating whether to check a user supplied Jacobian, if supplied. The default value is \code{FALSE}. The first 10 errors are printed. The code for this check is derived from the code in Bouaricha and Schnabel (1997).} \item{\code{delta}}{Initial (scaled) trust region radius. A value of \eqn{-1.0} or \code{"cauchy"} is replaced by the length of the Cauchy step in the initial point. A value of \eqn{-2.0} or \code{"newton"} is replaced by the length of the Newton step in the initial point. Any numeric value less than or equal to 0 and not equal to \eqn{-2.0}, will be replaced by \eqn{-1.0}; the algorithm will then start with the length of the Cauchy step in the initial point. If it is numeric and positive it will be set to the smaller of the value supplied or the maximum stepsize. If it is not numeric and not one of the permitted character strings then an error message will be issued. The default is \eqn{-2.0}.} \item{\code{stepmax}}{Maximum scaled stepsize. If this is negative then the maximum stepsize is set to the largest positive representable number. The default is \eqn{-1.0}, so there is no default maximum stepsize.} \item{\code{dsub}}{Number of non zero subdiagonals of a banded Jacobian. The default is to assume that the Jacobian is \emph{not} banded. Must be specified if \code{dsuper} has been specified and must be larger than zero when \code{dsuper} is zero.} \item{\code{dsuper}}{Number of non zero super diagonals of a banded Jacobian. The default is to assume that the Jacobian is \emph{not} banded. Must be specified if \code{dsub} has been specified and must be larger than zero when \code{dsub} is zero.} \item{\code{allowSingular}}{A logical value indicating if a small correction to the Jacobian when it is singular or too ill-conditioned is allowed. If the correction is less than \code{100*.Machine$double.eps} the correction cannot be applied and an unusable Jacobian will be reported. The method used is similar to a Levenberg-Marquardt correction and is explained in Dennis and Schnabel (1996) on page 151. It may be necessary to choose a higher value for \code{cndtol} to enforce the correction. The default value is \code{FALSE}. } } } } \value{ A list containing components \item{x}{final values for x} \item{fvec}{function values} \item{termcd}{termination code as integer. The values returned are \describe{ \item{\code{1}}{Function criterion is near zero. Convergence of function values has been achieved.} \item{\code{2}}{x-values within tolerance. This means that the relative distance between two consecutive x-values is smaller than \code{xtol} but that the function value criterion is still larger than \code{ftol}. \emph{Function values may not be near zero; therefore the user must check if function values are acceptably small.}} \item{\code{3}}{No better point found. This means that the algorithm has stalled and cannot find an acceptable new point. This may or may not indicate acceptably small function values.} \item{\code{4}}{Iteration limit \code{maxit} exceeded.} \item{\code{5}}{Jacobian is too ill-conditioned.} \item{\code{6}}{Jacobian is singular.} \item{\code{7}}{Jacobian is unusable.} \item{\code{-10}}{User supplied Jacobian is most likely incorrect.} } } \item{message}{a string describing the termination code} \item{scalex}{a vector containing the scaling factors, which will be the final values when automatic scaling was selected} \item{njcnt}{number of Jacobian evaluations} \item{nfcnt}{number of function evaluations, excluding those required for calculating a Jacobian and excluding the initial function evaluation (at iteration 0)} \item{iter}{number of outer iterations used by the algorithm. This excludes the initial iteration. The number of backtracks can be calculated as the difference between the \code{nfcnt} and \code{iter} components.} \item{jac}{the final Jacobian or the Broyden approximation if \code{jacobian} was set to \code{TRUE}. If no iterations were executed, as may happen when the initial guess are sufficiently close the solution, there is no Broyden approximation and the returned matrix will always be the actual Jacobian. If the matrix is singular or too ill-conditioned the returned matrix is of no value.} } %\note{ %} % \section{Warning}{You cannot use this function recursively. Thus function \code{fn} should not in its turn call \code{nleqslv}. } \seealso{If this function cannot solve the supplied function then it is a good idea to try the function \link{testnslv} in this package. For detecting multiple solutions see \link{searchZeros}.} \references{ Bouaricha, A. and Schnabel, R.B. (1997), Algorithm 768: TENSOLVE: A Software Package for Solving Systems of Nonlinear Equations and Nonlinear Least-squares Problems Using Tensor Methods, \emph{Transactions on Mathematical Software}, \bold{23}, 2, pp. 174--195. Dennis, J.E. Jr and Schnabel, R.B. (1996), \emph{Numerical Methods for Unconstrained Optimization and Nonlinear Equations}, Siam. \enc{Moré}{More}, J.J. (1978), The Levenberg-Marquardt Algorithm, Implementation and Theory, In \emph{Numerical Analysis}, G.A. Watson (Ed.), Lecture Notes in Mathematics 630, Springer-Verlag, pp. 105--116. Golub, G.H and C.F. Van Loan (1996), Matrix Computations (3rd edition), The John Hopkins University Press. Higham, N.J. (2002), Accuracy and Stability of Numerical Algorithms, 2nd ed., SIAM, pp. 10--11. Nocedal, J. and Wright, S.J. (2006), \emph{Numerical Optimization}, Springer. Powell, M.J.D. (1970), A hybrid method for nonlinear algebraic equations, In \emph{Numerical Methods for Nonlinear Algebraic Equations}, P. Rabinowitz (Ed.), Gordon \& Breach. Powell, M.J.D. (1970), A Fortran subroutine for solving systems nonlinear equations, In \emph{Numerical Methods for Nonlinear Algebraic Equations}, P. Rabinowitz (Ed.), Gordon \& Breach. % QRupdate: a Fortran library for fast updating of QR and Cholesky decompositions, % \url{http://sourceforge.net/projects/qrupdate/}. Reichel, L. and W.B. Gragg (1990), Algorithm 686: FORTRAN subroutines for updating the QR decomposition, \emph{ACM Trans. Math. Softw.}, \bold{16}, 4, pp. 369--377. } \examples{ # Dennis Schnabel example 6.5.1 page 149 dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } jacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 2*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 3*x[2]^2 Df } BADjacdsln <- function(x) { n <- length(x) Df <- matrix(numeric(n*n),n,n) Df[1,1] <- 4*x[1] Df[1,2] <- 2*x[2] Df[2,1] <- exp(x[1]-1) Df[2,2] <- 5*x[2]^2 Df } xstart <- c(2,0.5) fstart <- dslnex(xstart) xstart fstart # a solution is c(1,1) nleqslv(xstart, dslnex, control=list(btol=.01)) # Cauchy start nleqslv(xstart, dslnex, control=list(trace=1,btol=.01,delta="cauchy")) # Newton start nleqslv(xstart, dslnex, control=list(trace=1,btol=.01,delta="newton")) # final Broyden approximation of Jacobian (quite good) z <- nleqslv(xstart, dslnex, jacobian=TRUE,control=list(btol=.01)) z$x z$jac jacdsln(z$x) # different initial start; not a very good final approximation xstart <- c(0.5,2) z <- nleqslv(xstart, dslnex, jacobian=TRUE,control=list(btol=.01)) z$x z$jac jacdsln(z$x) \dontrun{ # no global strategy but limit stepsize # but look carefully: a different solution is found nleqslv(xstart, dslnex, method="Newton", global="none", control=list(trace=1,stepmax=5)) # but if the stepsize is limited even more the c(1,1) solution is found nleqslv(xstart, dslnex, method="Newton", global="none", control=list(trace=1,stepmax=2)) # Broyden also finds the c(1,1) solution when the stepsize is limited nleqslv(xstart, dslnex, jacdsln, method="Broyden", global="none", control=list(trace=1,stepmax=2)) } # example with a singular jacobian in the initial guess f <- function(x) { y <- numeric(3) y[1] <- x[1] + x[2] - x[1]*x[2] - 2 y[2] <- x[1] + x[3] - x[1]*x[3] - 3 y[3] <- x[2] + x[3] - 4 return(y) } Jac <- function(x) { J <- matrix(0,nrow=3,ncol=3) J[,1] <- c(1-x[2],1-x[3],0) J[,2] <- c(1-x[1],0,1) J[,3] <- c(0,1-x[1],1) J } # exact solution xsol <- c(-.5, 5/3 , 7/3) xsol xstart <- c(1,2,3) J <- Jac(xstart) J rcond(J) z <- nleqslv(xstart,f,Jac, method="Newton",control=list(trace=1,allowSingular=TRUE)) all.equal(z$x,xsol) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{nonlinear} \keyword{optimize} nleqslv/man/zznleqslv-iterationreport.Rd0000644000175100001440000002542012475642435020335 0ustar hornikusers\name{nleqslv-iterationreport} \alias{Iteration report} \title{Detailed iteration report of nleqslv} \description{ The format of the iteration report provided by nleqslv when the \code{trace} component of the \code{control} argument has been set to 1. } \details{ All iteration reports consist of a series of columns with a header summarising the contents. Common column headers are \describe{ \item{\code{Iter}}{Iteration counter} \item{\code{Jac}}{Jacobian type. The Jacobian type is indicated by \code{N} for a Newton Jacobian or \code{B} for a Broyden updated matrix; optionally followed by the letter \code{s} indicating a totally singular matrix or the letter \code{i} indicating an ill-conditioned matrix. Unless the Jacobian is singular, the Jacobian type is followed by an estimate of the inverse condition number of the Jacobian in parentheses as computed by Lapack. This column will be blank when backtracking is active.} \item{\code{Fnorm}}{square of the euclidean norm of function values / 2} \item{\code{Largest |f|}}{infinity norm of \eqn{f(x)}{f(x)} at the current point} } } \section{Report for linesearch methods}{ A sample iteration report for the linesearch global methods (\code{cline}, \code{qline} and \code{gline}) is (some intercolumn space has been removed to make the table fit) \preformatted{ Iter Jac Lambda Ftarg Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) 1.0000 2.886235e+00 5.787362e+05 1.070841e+03 1 0.1000 2.886754e+00 9.857947e+00 3.214799e+00 1 0.0100 2.886806e+00 2.866321e+00 2.237878e+00 2 B(2.2e-02) 1.0000 2.865748e+00 4.541965e+03 9.341610e+01 2 0.1000 2.866264e+00 3.253536e+00 2.242344e+00 2 0.0298 2.866304e+00 2.805872e+00 2.200544e+00 3 B(5.5e-02) 1.0000 2.805311e+00 2.919089e+01 7.073082e+00 3 0.1000 2.805816e+00 2.437606e+00 2.027297e+00 4 B(1.0e-01) 1.0000 2.437118e+00 9.839802e-01 1.142529e+00 } The column headed by \code{Lambda} shows the value of the line search parameter. The column headed by \code{Ftarg} follows from a sufficient decrease requirement and is the value below which \code{Fnorm} must drop if the current step is to be accepted. The value of \code{Lambda} may not be lower than a threshold determined by the setting of control parameter \code{xtol} to avoid reporting false convergence. When no acceptable \code{Lambda} is possible and the Broyden method is being used, a new Jacobian will be computed. } \section{Report for the pure method}{ The iteration report for the global method \code{none} is almost the same as the above report, except that the column labelled \code{Ftarg} is omitted. The column \code{Lambda} gives the ratio of the maximum stepsize and the length of the full Newton step. It is either exactly 1.0, indicating that the Newton step is smaller than the maximum stepsize and therefore used unmodified, or smaller than 1.0, indicating that the Newton step is larger than the maximum stepsize and therefore truncated. } \section{Report for the double dogleg global method}{ A sample iteration report for the global method \code{dbldog} is (some intercolumn space has been removed to make the table fit) \preformatted{ Iter Jac Lambda Eta Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) C 0.9544 0.4671 0.9343* 1.699715e-01 5.421673e-01 1 W 0.0833 0.9544 0.9343 0.4671 1.699715e-01 5.421673e-01 2 B(1.1e-02) W 0.1154 0.4851 0.4671 0.4671 1.277667e-01 5.043571e-01 3 B(7.3e-02) W 0.7879 0.7289 0.4671 0.0759 5.067893e-01 7.973542e-01 3 C 0.7289 0.0759 0.1519 5.440250e-02 2.726084e-01 4 B(8.3e-02) W 0.5307 0.3271 0.1519 0.3037 3.576547e-02 2.657553e-01 5 B(1.8e-01) N 0.6674 0.2191 0.4383 6.566182e-03 8.555110e-02 6 B(1.8e-01) N 0.9801 0.0376 0.0752 4.921645e-04 3.094104e-02 7 B(1.9e-01) N 0.7981 0.0157 0.0313 4.960629e-06 2.826064e-03 8 B(1.6e-01) N 0.3942 0.0029 0.0058 1.545503e-08 1.757498e-04 9 B(1.5e-01) N 0.6536 0.0001 0.0003 2.968676e-11 5.983765e-06 10 B(1.5e-01) N 0.4730 0.0000 0.0000 4.741792e-14 2.198380e-07 11 B(1.5e-01) N 0.9787 0.0000 0.0000 6.451792e-19 8.118586e-10 } After the column for the Jacobian the letters indicate the following \describe{ \item{\code{C}}{a fraction (\eqn{\le1.0}{<=1.0}) of the Cauchy or steepest descent step is taken where the fraction is the ratio of the trust region radius and the Cauchy steplength.} \item{\code{W}}{a convex combination of the Cauchy and \code{eta}*(Newton step) is taken. The number in the column headed by \code{Lambda} is the weight of the partial Newton step.} \item{\code{P}}{a fraction (\eqn{\ge1.0}{>=1.0}) of the partial Newton step, equal to \code{eta}*(Newton step), is taken where the fraction is the ratio of the trust region radius and the partial Newton steplength.} \item{\code{N}}{a normal full Newton step is taken.} } The number in the column headed by \code{Eta} is calculated from an upper limit on the ratio of the length of the steepest descent direction and the length of the Newton step. See Dennis and Schnabel (1996) pp.139ff for the details. The column headed by \code{Dlt0} gives the trust region size at the start of the current iteration. The column headed by \code{Dltn} gives the trust region size when the current step has been accepted by the dogleg algorithm. The trust region size is decreased when the actual reduction of the function value norm does not agree well with the predicted reduction from the linear approximation of the function or does not exhibit sufficient decrease. And increased when the actual and predicted reduction are sufficiently close. The trust region size is not allowed to decrease beyond a threshold determined by the setting of control parameter \code{xtol}; when that happens the backtracking is regarded as a failure and is terminated. In that case a new Jacobian will be calculated if the Broyden method is being used. The current trust region step is continued with a doubled trust region size when the actual and predicted reduction agree extremely well. This is indicated by \code{*} immediately following the value in the column headed by \code{Dltn}. This could save gradient calculations. However, a trial step is never taken if the current step is a Newton step. If the trial step does not succeed then the previous trust region size is restored by halving the trial size. The exception is when a trial step takes a Newton step. In that case the trust region size is immediately set to the size of the Newton step which implies that a halving of the new size leads to a smaller size for the trust region than before. Normally the initial trust region radius is the same as the final trust region radius of the previous iteration but the trust region size is restricted by the size of the current Newton step. So when full Newton steps are being taken, the trust region radius at the start of an iteration may be less than the final value of the previous iteration. The double dogleg method and the trust region updating procedure are fully explained in sections 6.4.2 and 6.4.3 of Dennis and Schnabel (1996). } \section{Report for the single (Powell) dogleg global method}{ A sample iteration report for the global method \code{pwldog} is (some intercolumn space has been removed to make the table fit) \preformatted{ Iter Jac Lambda Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) C 0.4671 0.9343* 1.699715e-01 5.421673e-01 1 W 0.0794 0.9343 0.4671 1.699715e-01 5.421673e-01 2 B(1.1e-02) W 0.0559 0.4671 0.4671 1.205661e-01 4.890487e-01 3 B(7.3e-02) W 0.5662 0.4671 0.0960 4.119560e-01 7.254441e-01 3 W 0.0237 0.0960 0.1921 4.426507e-02 2.139252e-01 4 B(8.8e-02) W 0.2306 0.1921 0.3842* 2.303135e-02 2.143943e-01 4 W 0.4769 0.3842 0.1921 2.303135e-02 2.143943e-01 5 B(1.9e-01) N 0.1375 0.2750 8.014508e-04 3.681498e-02 6 B(1.7e-01) N 0.0162 0.0325 1.355741e-05 5.084627e-03 7 B(1.3e-01) N 0.0070 0.0035 1.282776e-05 4.920962e-03 8 B(1.8e-01) N 0.0028 0.0056 3.678140e-08 2.643592e-04 9 B(1.9e-01) N 0.0001 0.0003 1.689182e-12 1.747622e-06 10 B(1.9e-01) N 0.0000 0.0000 9.568768e-16 4.288618e-08 11 B(1.9e-01) N 0.0000 0.0000 1.051357e-18 1.422036e-09 } This is much simpler than the double dogleg report, since the single dogleg takes either a steepest descent step, a convex combination of the steepest descent and Newton steps or a full Newton step. The number in the column \code{Lambda} is the weight of the Newton step. The single dogleg method is a special case of the double dogleg method with \code{eta} equal to 1. It uses the same method of updating the trust region size as the double dogleg method. } \section{Report for the hook step global method}{ A sample iteration report for the global method \code{hook} is (some intercolumn space has been removed to make the table fit) \preformatted{ Iter Jac mu dnorm Dlt0 Dltn Fnorm Largest |f| 0 2.886812e+00 2.250000e+00 1 N(9.6e-03) H 0.1968 0.4909 0.4671 0.9343* 1.806293e-01 5.749418e-01 1 H 0.0366 0.9381 0.9343 0.4671 1.806293e-01 5.749418e-01 2 B(2.5e-02) H 0.1101 0.4745 0.4671 0.2336 1.797759e-01 5.635028e-01 3 B(1.4e-01) H 0.0264 0.2341 0.2336 0.4671 3.768809e-02 2.063234e-01 4 B(1.6e-01) N 0.0819 0.0819 0.1637 3.002274e-03 7.736213e-02 5 B(1.8e-01) N 0.0513 0.0513 0.1025 5.355533e-05 1.018879e-02 6 B(1.5e-01) N 0.0090 0.0090 0.0179 1.357039e-06 1.224357e-03 7 B(1.5e-01) N 0.0004 0.0004 0.0008 1.846111e-09 6.070166e-05 8 B(1.4e-01) N 0.0000 0.0000 0.0001 3.292896e-12 2.555851e-06 9 B(1.5e-01) N 0.0000 0.0000 0.0000 7.281583e-18 3.800552e-09 } The column headed by \code{mu} shows the Levenberg-Marquardt parameter when the Newton step is larger than the trust region radius. The column headed by \code{dnorm} gives the Euclidean norm of the step (adjustment of the current \code{x}) taken by the algorithm. The absolute value of the difference with \code{Dlt0} is less than 0.1 times the trust region radius. After the column for the Jacobian the letters indicate the following \describe{ \item{\code{H}}{a Levenberg-Marquardt restricted step is taken.} \item{\code{N}}{a normal full Newton step is taken.} } The meaning of the columns headed by \code{Dlt0} and \code{Dltn} is identical to that of the same columns for the double dogleg method. The method of updating the trust region size is the same as in the double dogleg method. } \seealso{\code{\link{nleqslv}}} nleqslv/man/nleqslv-package.Rd0000644000175100001440000000365112734147307016110 0ustar hornikusers\name{nleqslv-package} \alias{nleqslv-package} \alias{nleqslv.Intro} \docType{package} \title{Solving Nonlinear Systems of Equations} \description{ The \pkg{nleqslv} package provides two algorithms for solving (dense) nonlinear systems of equations. The methods provided are \itemize{ \item a Broyden Secant method where the matrix of derivatives is updated after each major iteration using the Broyden rank 1 update. \item a full Newton method where the Jacobian matrix of derivatives is recalculated at each iteration } Both methods utilize global strategies such as line search or trust region methods whenever the standard Newton/Broyden step does not lead to a point closer to a root of the equation system. Both methods can also be used without a norm reducing global strategy. Line search may be either cubic, quadratic or geometric. The trust region methods are either the double dogleg method, the Powell single dogleg method or a Levenberg-Marquardt type method. There is a facility for specifying that the Jacobian is banded; this can significantly speedup the calculation of a numerical Jacobian when the number of sub- and super diagonals is small compared to the size of the system of equations. For example the Jacobian of a tridiagonal system can be calculated with only three evaluations of the function. The package provides an option to attempt to solve the system of equations when the Jacobian is singular or ill-conditioned using an approximation to the Moore-Penrose pseudoinverse of the Jacobian. The algorithms provided in this package are derived from Dennis and Schnabel (1996). The code is written in Fortran 77 and Fortran 95 and uses Lapack and BLAS routines as provided by the R system. } \author{Berend Hasselman \email{bhh@xs4all.nl}} \references{ Dennis, J.E. Jr and Schnabel, R.B. (1996), \emph{Numerical Methods for Unconstrained Optimization and Nonlinear Equations}, Siam. } \keyword{package} nleqslv/man/testnslv.Rd0000644000175100001440000001023412747127260014710 0ustar hornikusers\name{testnslv} \alias{testnslv} \encoding{UTF-8} \title{Test different methods for solving with \code{nleqslv}} \description{ The function tests different methods and global strategies for solving a system of nonlinear equations with \code{nleqslv} } \usage{ testnslv(x, fn, jac=NULL, ..., method = c("Newton", "Broyden"), global = c("cline", "qline", "gline", "pwldog", "dbldog", "hook", "none"), Nrep=0L, title=NULL ) } \arguments{ \item{x}{A numeric vector with an initial guess of the root.} \item{fn}{A function of \code{x} returning the function values.} \item{jac}{A function to return the Jacobian for the \code{fn} function. For a vector valued function \code{fn} the Jacobian must be a numeric matrix of the correct dimensions. For a scalar valued function \code{fn} the \code{jac} function may return a scalar. If not supplied numerical derivatives will be used.} \item{\dots}{Further arguments to be passed to \code{fn} and \code{jac} and \code{\link{nleqslv}}.} \item{method}{The methods to use for finding a solution.} \item{global}{The global strategies to test. The argument may consist of several possibly abbreviated items.} \item{Nrep}{Number of repetitions to apply. Default is no repetitions.} \item{title}{a description of this experiment.} } \details{The function solves the function \code{fn} with \code{\link{nleqslv}} for the specified methods and global strategies. When argument \code{Nrep} has been set to a number greater than or equal to 1, repetitions of the solving process are performed and the used CPU time in seconds is recorded. If checking a user supplied jacobian is enabled, then \code{testnslv} will stop immediately when a possibly incorrect jacobian is detected. } \value{ \code{testnslv} returns an object of class \code{"test.nleqslv"} which is a list containing the following elements \describe{ \item{\code{call}}{the matched call} \item{\code{out}}{ a dataframe containing the results with the following columns \describe{ \item{\code{Method}}{method used.} \item{\code{Global}}{global strategy used.} \item{\code{termcd}}{termination code of \code{nleqslv}.} \item{\code{Fcnt}}{number of function evaluations used by the method and global strategy. This excludes function evaluations made when computing a numerical Jacobian.} \item{\code{Jcnt}}{number of Jacobian evaluations.} \item{\code{Iter}}{number of outer iterations used by the algorithm.} \item{\code{Message}}{a string describing the termination code in an abbreviated form.} \item{\code{Fnorm}}{square of the euclidean norm of the vector of function results divided by 2.} \item{\code{cpusecs}}{CPU seconds used by the requested number of repetitions (only present when argument \code{Nrep} is not 0).} } } \item{\code{title}}{the description if specified} } The abbreviated strings are \describe{ \item{\code{Fcrit}}{Convergence of function values has been achieved.} \item{\code{Xcrit}}{This means that the relative distance between two consecutive x-values is smaller than \code{xtol}.} \item{\code{Stalled}}{The algorithm cannot find an acceptable new point.} \item{\code{Maxiter}}{Iteration limit \code{maxit} exceeded.} \item{\code{Illcond}}{Jacobian is too ill-conditioned.} \item{\code{Singular}}{Jacobian is singular.} \item{\code{BadJac}}{Jacobian is unusable.} \item{\code{ERROR}}{\code{nleqslv} stopped because of a fatal error.} } } \section{Warning}{ Any \code{nleqslv} error message will be displayed immediately and an error for the particular combination of method and global strategy will be recorded in the final dataframe. } \examples{ dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } xstart <- c(0.5,0.5) fstart <- dslnex(xstart) testnslv(xstart,dslnex) # this will encounter an error xstart <- c(2.0,0.5) fstart <- dslnex(xstart) testnslv(xstart,dslnex) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{nonlinear} \keyword{optimize} nleqslv/man/print.testnslv.Rd0000644000175100001440000000223612512424446016042 0ustar hornikusers \name{print.test.nleqslv} \title{Printing the result of \code{testnslv}} \alias{print} \alias{print.test.nleqslv} \description{ Print method for \code{test.nleqslv} objects. } \usage{ \method{print}{test.nleqslv}(x, digits=4, width.cutoff=45L, \dots) } \arguments{ \item{x}{a \code{test.nleqslv} object} \item{digits}{specifies the minimum number of significant digits to be printed in values.} \item{width.cutoff}{integer passed to \code{\link{deparse}} which sets the cutoff at which line-breaking is tried.} \item{\dots}{additional arguments to \code{print}.} } \details{ This is the \code{print} method for objects inheriting from class \code{test.nleqslv}. It prints the call to \code{testnslv} followed by the description of the experiment (if the \code{title} argument was specified in the call to \code{testnslv}) and the dataframe containing the results of \code{testnslv}. } \value{ It returns the object \code{x} invisibly. } \examples{ dslnex <- function(x) { y <- numeric(2) y[1] <- x[1]^2 + x[2]^2 - 2 y[2] <- exp(x[1]-1) + x[2]^3 - 2 y } xstart <- c(1.5,0.5) fstart <- dslnex(xstart) z <- testnslv(xstart,dslnex) print(z) } \keyword{print}