[r-cran-nleqslv] 01/02: Import Upstream version 3.0.3
Sébastien Villemot
sebastien at debian.org
Thu Oct 13 21:23:56 UTC 2016
This is an automated email from the git hooks/post-receive script.
sebastien pushed a commit to branch master
in repository r-cran-nleqslv.
commit 13295ba6eed095e11d92a7a9e9dc8fa35f5e0865
Author: Sébastien Villemot <sebastien at debian.org>
Date: Thu Oct 13 23:22:45 2016 +0200
Import Upstream version 3.0.3
---
DESCRIPTION | 17 +
MD5 | 111 ++++
NAMESPACE | 6 +
NEWS | 276 +++++++++
R/nleqslv.R | 72 +++
R/searchzeros.R | 72 +++
R/testnslv.R | 97 +++
inst/iterationreport/00readme.txt | 21 +
inst/iterationreport/dsdbldog.R | 29 +
inst/iterationreport/dsdbldog.Rout | 106 ++++
inst/iterationreport/dsdbldog.Rout.txt | 15 +
inst/iterationreport/dshook.R | 29 +
inst/iterationreport/dshook.Rout | 103 ++++
inst/iterationreport/dshook.Rout.txt | 12 +
inst/iterationreport/dslnsrch.R | 24 +
inst/iterationreport/dslnsrch.Rout | 221 +++++++
inst/iterationreport/dslnsrch.Rout.txt | 66 ++
inst/iterationreport/dspure.R | 29 +
inst/iterationreport/dspure.Rout | 104 ++++
inst/iterationreport/dspure.Rout.txt | 13 +
inst/iterationreport/dspwldog.R | 29 +
inst/iterationreport/dspwldog.Rout | 107 ++++
inst/iterationreport/dspwldog.Rout.txt | 16 +
man/nleqslv-package.Rd | 42 ++
man/nleqslv.Rd | 413 +++++++++++++
man/print.testnslv.Rd | 39 ++
man/searchzeros.Rd | 108 ++++
man/testnslv.Rd | 93 +++
man/zznleqslv-iterationreport.Rd | 189 ++++++
src/Makevars | 3 +
src/lautil.f | 135 +++++
src/limhpar.f | 89 +++
src/liqrev.f | 220 +++++++
src/liqrup.f | 111 ++++
src/lirslv.f | 80 +++
src/nleqslv.c | 528 ++++++++++++++++
src/nwbjac.f | 185 ++++++
src/nwbrdn.f | 438 ++++++++++++++
src/nwclsh.f | 174 ++++++
src/nwddlg.f | 239 ++++++++
src/nwglsh.f | 125 ++++
src/nwmhlm.f | 205 +++++++
src/nwnjac.f | 174 ++++++
src/nwnleq.f | 320 ++++++++++
src/nwnwtn.f | 249 ++++++++
src/nwout.c | 325 ++++++++++
src/nwpdlg.f | 219 +++++++
src/nwpure.f | 82 +++
src/nwqlsh.f | 125 ++++
src/nwtrup.f | 164 +++++
src/nwutil.f | 1028 ++++++++++++++++++++++++++++++++
tests/brdban.R | 57 ++
tests/brdban.Rout | 86 +++
tests/brdban.Rout.save | 86 +++
tests/brdbanded.R | 59 ++
tests/brdbanded.Rout | 98 +++
tests/brdbanded.Rout.save | 98 +++
tests/brdtri.R | 50 ++
tests/brdtri.Rout | 89 +++
tests/brdtri.Rout.save | 89 +++
tests/brdtrijac.R | 50 ++
tests/brdtrijac.Rout | 80 +++
tests/brdtrijac.Rout.save | 80 +++
tests/chquad.R | 54 ++
tests/chquad.Rout | 92 +++
tests/chquad.Rout.save | 92 +++
tests/control-try.R | 15 +
tests/control-try.Rout.save | 41 ++
tests/dslnex.R | 71 +++
tests/dslnex.Rout | 124 ++++
tests/dslnex.Rout.save | 124 ++++
tests/dslnexCN.R | 52 ++
tests/dslnexCN.Rout | 76 +++
tests/dslnexCN.Rout.save | 76 +++
tests/dslnexHook.R | 54 ++
tests/dslnexHook.Rout | 99 +++
tests/dslnexHook.Rout.save | 99 +++
tests/dslnexauto.R | 71 +++
tests/dslnexauto.Rout | 123 ++++
tests/dslnexauto.Rout.save | 123 ++++
tests/dslnexjacout.R | 52 ++
tests/dslnexjacout.Rout | 88 +++
tests/dslnexjacout.Rout.save | 88 +++
tests/dslnexscaled.R | 60 ++
tests/dslnexscaled.Rout | 100 ++++
tests/dslnexscaled.Rout.save | 100 ++++
tests/singular1.R | 41 ++
tests/singular1.Rout | 69 +++
tests/singular1.Rout.save | 69 +++
tests/singular2.R | 70 +++
tests/singular2.Rout | 97 +++
tests/singular2.Rout.save | 97 +++
tests/singular3.R | 42 ++
tests/singular3.Rout | 67 +++
tests/singular3.Rout.save | 66 ++
tests/trig.R | 42 ++
tests/trig.Rout | 66 ++
tests/trig.Rout.save | 66 ++
tests/tscalargrad.R | 26 +
tests/tscalargrad.Rout.save | 52 ++
tests/xcutlip1p2.R | 54 ++
tests/xcutlip1p2.Rout | 79 +++
tests/xcutlip1p2.Rout.save | 79 +++
tests/xnames.R | 23 +
tests/xnames.Rout | 53 ++
tests/xnames.Rout.save | 53 ++
tests/xsearchzeros.R | 27 +
tests/xsearchzeros.Rout | 51 ++
tests/xsearchzeros.Rout.save | 51 ++
tests/xtestnslv.R | 34 ++
tests/xtestnslv.Rout | 94 +++
tests/xtestnslv.Rout.save | 94 +++
112 files changed, 12035 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..f543c73
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,17 @@
+Package: nleqslv
+Type: Package
+Title: Solve Systems of Nonlinear Equations
+Version: 3.0.3
+Date: 2016-08-08
+Author: Berend Hasselman
+Maintainer: Berend Hasselman <bhh at xs4all.nl>
+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: 2016-08-07 17:38:12 UTC; berendhasselman
+Repository: CRAN
+Date/Publication: 2016-08-08 17:19:53
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..f93f372
--- /dev/null
+++ b/MD5
@@ -0,0 +1,111 @@
+221d88e0bb9bd0c9b0f9c7c125c6a1e5 *DESCRIPTION
+33fbdf15197803cd9b89706fbff463c7 *NAMESPACE
+736c08ecb5c37eaa4133b0882fa80178 *NEWS
+c1fafc50b261ee0214cd29408d5bb791 *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
+526b2b6a6cebf3d6bdd8ad58ece8cba4 *man/nleqslv.Rd
+3daad4ddd6cbf326478a613c86c93015 *man/print.testnslv.Rd
+62c35752b6e8cd1a5c8f59cac2c8ad20 *man/searchzeros.Rd
+a291e7c0ef44985835aa9856764783ad *man/testnslv.Rd
+9290ebb081a2f9def80826a6555f3fb6 *man/zznleqslv-iterationreport.Rd
+1ed18cd8f15e511a405098ea1e6cc224 *src/Makevars
+9ddf400ab9fcbaa36b158ee9412cd7ee *src/lautil.f
+adbe16b0f0703e1cca12061c7426388b *src/limhpar.f
+6738247bac3f2ac8f88bb0176560d137 *src/liqrev.f
+6bb33b8afa14e8bec2dad29c3b3be862 *src/liqrup.f
+d83a0b755fccf6fa9bd593fe73a24514 *src/lirslv.f
+8786461dc183476f70cbc1088fbae795 *src/nleqslv.c
+39aa2bee1e689c9a1d9ad427a2996c9a *src/nwbjac.f
+006767c20f9b38cea482779c3b98caf5 *src/nwbrdn.f
+8addf8de63f1b9690f67fb53a99dd929 *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
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..4c44f59
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,6 @@
+useDynLib(nleqslv)
+export(nleqslv)
+export(testnslv)
+export(searchZeros)
+
+S3method(print,test.nleqslv)
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..f804c90
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,276 @@
+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 <iter> 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
diff --git a/R/nleqslv.R b/R/nleqslv.R
new file mode 100644
index 0000000..1fd9975
--- /dev/null
+++ b/R/nleqslv.R
@@ -0,0 +1,72 @@
+#
+# 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("deactivatenleq",PACKAGE="nleqslv"))
+ out <- .Call("nleqslv", x, fn1, jacfunc, method, global, xscalm, jacobian, con, new.env(), PACKAGE = "nleqslv")
+
+ out
+}
diff --git a/R/searchzeros.R b/R/searchzeros.R
new file mode 100644
index 0000000..179e6d9
--- /dev/null
+++ b/R/searchzeros.R
@@ -0,0 +1,72 @@
+searchZeros <- 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
+}
diff --git a/R/testnslv.R b/R/testnslv.R
new file mode 100644
index 0000000..1042dd3
--- /dev/null
+++ b/R/testnslv.R
@@ -0,0 +1,97 @@
+
+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)
+}
diff --git a/inst/iterationreport/00readme.txt b/inst/iterationreport/00readme.txt
new file mode 100644
index 0000000..e9da653
--- /dev/null
+++ b/inst/iterationreport/00readme.txt
@@ -0,0 +1,21 @@
+
+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 <path to nleqslv package-source>/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.
diff --git a/inst/iterationreport/dsdbldog.R b/inst/iterationreport/dsdbldog.R
new file mode 100644
index 0000000..8328705
--- /dev/null
+++ b/inst/iterationreport/dsdbldog.R
@@ -0,0 +1,29 @@
+# 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"))
diff --git a/inst/iterationreport/dsdbldog.Rout b/inst/iterationreport/dsdbldog.Rout
new file mode 100644
index 0000000..a47d538
--- /dev/null
+++ b/inst/iterationreport/dsdbldog.Rout
@@ -0,0 +1,106 @@
+
+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
+
+>
diff --git a/inst/iterationreport/dsdbldog.Rout.txt b/inst/iterationreport/dsdbldog.Rout.txt
new file mode 100644
index 0000000..6aff37b
--- /dev/null
+++ b/inst/iterationreport/dsdbldog.Rout.txt
@@ -0,0 +1,15 @@
+ 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
diff --git a/inst/iterationreport/dshook.R b/inst/iterationreport/dshook.R
new file mode 100644
index 0000000..965393c
--- /dev/null
+++ b/inst/iterationreport/dshook.R
@@ -0,0 +1,29 @@
+# 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"))
diff --git a/inst/iterationreport/dshook.Rout b/inst/iterationreport/dshook.Rout
new file mode 100644
index 0000000..fb8d050
--- /dev/null
+++ b/inst/iterationreport/dshook.Rout
@@ -0,0 +1,103 @@
+
+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
+
+>
diff --git a/inst/iterationreport/dshook.Rout.txt b/inst/iterationreport/dshook.Rout.txt
new file mode 100644
index 0000000..fbf5c30
--- /dev/null
+++ b/inst/iterationreport/dshook.Rout.txt
@@ -0,0 +1,12 @@
+ 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
diff --git a/inst/iterationreport/dslnsrch.R b/inst/iterationreport/dslnsrch.R
new file mode 100644
index 0000000..51b42c9
--- /dev/null
+++ b/inst/iterationreport/dslnsrch.R
@@ -0,0 +1,24 @@
+# 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))
diff --git a/inst/iterationreport/dslnsrch.Rout b/inst/iterationreport/dslnsrch.Rout
new file mode 100644
index 0000000..15c0175
--- /dev/null
+++ b/inst/iterationreport/dslnsrch.Rout
@@ -0,0 +1,221 @@
+
+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
+
+>
diff --git a/inst/iterationreport/dslnsrch.Rout.txt b/inst/iterationreport/dslnsrch.Rout.txt
new file mode 100644
index 0000000..ad53fb2
--- /dev/null
+++ b/inst/iterationreport/dslnsrch.Rout.txt
@@ -0,0 +1,66 @@
+ 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
diff --git a/inst/iterationreport/dspure.R b/inst/iterationreport/dspure.R
new file mode 100644
index 0000000..76bf85c
--- /dev/null
+++ b/inst/iterationreport/dspure.R
@@ -0,0 +1,29 @@
+# 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))
diff --git a/inst/iterationreport/dspure.Rout b/inst/iterationreport/dspure.Rout
new file mode 100644
index 0000000..531afb6
--- /dev/null
+++ b/inst/iterationreport/dspure.Rout
@@ -0,0 +1,104 @@
+
+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
+
+>
diff --git a/inst/iterationreport/dspure.Rout.txt b/inst/iterationreport/dspure.Rout.txt
new file mode 100644
index 0000000..8e4e34f
--- /dev/null
+++ b/inst/iterationreport/dspure.Rout.txt
@@ -0,0 +1,13 @@
+ 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
diff --git a/inst/iterationreport/dspwldog.R b/inst/iterationreport/dspwldog.R
new file mode 100644
index 0000000..b099bff
--- /dev/null
+++ b/inst/iterationreport/dspwldog.R
@@ -0,0 +1,29 @@
+# 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"))
diff --git a/inst/iterationreport/dspwldog.Rout b/inst/iterationreport/dspwldog.Rout
new file mode 100644
index 0000000..7b469f7
--- /dev/null
+++ b/inst/iterationreport/dspwldog.Rout
@@ -0,0 +1,107 @@
+
+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
+
+>
diff --git a/inst/iterationreport/dspwldog.Rout.txt b/inst/iterationreport/dspwldog.Rout.txt
new file mode 100644
index 0000000..bc101f5
--- /dev/null
+++ b/inst/iterationreport/dspwldog.Rout.txt
@@ -0,0 +1,16 @@
+ 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
diff --git a/man/nleqslv-package.Rd b/man/nleqslv-package.Rd
new file mode 100644
index 0000000..56711d6
--- /dev/null
+++ b/man/nleqslv-package.Rd
@@ -0,0 +1,42 @@
+\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 at xs4all.nl}}
+
+\references{
+Dennis, J.E. Jr and Schnabel, R.B. (1996), \emph{Numerical Methods for Unconstrained Optimization
+and Nonlinear Equations}, Siam.
+}
+\keyword{package}
diff --git a/man/nleqslv.Rd b/man/nleqslv.Rd
new file mode 100644
index 0000000..c7a892c
--- /dev/null
+++ b/man/nleqslv.Rd
@@ -0,0 +1,413 @@
+\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 uses a modified version of the algorithm described in Dennis and Schnabel (1996).
+}
+
+\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}
diff --git a/man/print.testnslv.Rd b/man/print.testnslv.Rd
new file mode 100644
index 0000000..aefd43a
--- /dev/null
+++ b/man/print.testnslv.Rd
@@ -0,0 +1,39 @@
+
+\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}
diff --git a/man/searchzeros.Rd b/man/searchzeros.Rd
new file mode 100644
index 0000000..a60a72a
--- /dev/null
+++ b/man/searchzeros.Rd
@@ -0,0 +1,108 @@
+\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 the 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.
+They are not returned in the return value of the function.
+}
+\value{
+If no solutions are found \code{NULL} otherwise
+a list containing components
+ \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}
diff --git a/man/testnslv.Rd b/man/testnslv.Rd
new file mode 100644
index 0000000..2de80ab
--- /dev/null
+++ b/man/testnslv.Rd
@@ -0,0 +1,93 @@
+\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}
diff --git a/man/zznleqslv-iterationreport.Rd b/man/zznleqslv-iterationreport.Rd
new file mode 100644
index 0000000..5064624
--- /dev/null
+++ b/man/zznleqslv-iterationreport.Rd
@@ -0,0 +1,189 @@
+\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}}}
diff --git a/src/Makevars b/src/Makevars
new file mode 100644
index 0000000..6386f5f
--- /dev/null
+++ b/src/Makevars
@@ -0,0 +1,3 @@
+PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
+# used when checking
+###PKG_FFLAGS = -fimplicit-none
diff --git a/src/lautil.f b/src/lautil.f
new file mode 100644
index 0000000..366760e
--- /dev/null
+++ b/src/lautil.f
@@ -0,0 +1,135 @@
+
+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
diff --git a/src/limhpar.f b/src/limhpar.f
new file mode 100644
index 0000000..b1d29e2
--- /dev/null
+++ b/src/limhpar.f
@@ -0,0 +1,89 @@
+ 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
diff --git a/src/liqrev.f b/src/liqrev.f
new file mode 100644
index 0000000..ac14857
--- /dev/null
+++ b/src/liqrev.f
@@ -0,0 +1,220 @@
+
+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
+
+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 | = | z |
+c | y | | 0 |
+c
+c resulting in
+c
+c c * x + s * y = z
+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
+
+ double precision t
+
+ double precision Rzero
+ parameter(Rzero=0.0d0)
+
+ call dlartg(x,y,c,s,t)
+ x = t
+ y = Rzero
+ return
+ end
diff --git a/src/liqrup.f b/src/liqrup.f
new file mode 100644
index 0000000..5aa278f
--- /dev/null
+++ b/src/liqrup.f
@@ -0,0 +1,111 @@
+ 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 Source : procedure outlined in Dennis & Schnabel (Appendix A)
+c Algorithm 3.1.4 and 3.4.1a
+c modified (to use Lapack routines and more)
+c
+c-----------------------------------------------------------------------------
+
+c Local variables and functions
+
+ integer k,i
+ double precision ddot
+
+c calculate wk = trans(Q)*u
+
+ do i=1,n
+ wk(i) = ddot(n,Q(1,i),1,u,1)
+ enddo
+
+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 jacrot(wk(k),wk(k+1),k,n,Q,ldq,R,ldr,k)
+ 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.
+c kr argument == k+1 to start applying rotation at column k+1
+c otherwise R(k,k) will be rotated twice and this way it also
+c avoids tiny roundoff errors.
+
+ do k=1,n-1
+ call jacrot(R(k,k),R(k+1,k),k,n,Q,ldq,R,ldr,k+1)
+ enddo
+
+ return
+ end
+
+c-----------------------------------------------------------------------------
+
+ subroutine jacrot(a,b,k,n,Q,ldq,R,ldr,kr)
+
+ double precision a, b
+ integer k,n,ldr,ldq,kr
+ double precision Q(ldq,*), R(ldr,*)
+
+c-----------------------------------------------------------------------------
+c
+c Arguments
+c
+c Inout a Real rotate argument
+c Inout b Real rotate argument to rotate to zero
+c In k Integer row/column number for rotation
+c In n Integer order of Q and R
+c Inout Q Real(ldq,n) orthogonal matrix from QR
+c In ldq Integer leading dimension of Q
+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 In kr Integer start R rotation in column kr
+c (should be k or k+1)
+c
+c-----------------------------------------------------------------------------
+
+ double precision t
+ double precision c,s
+ double precision Rzero
+ parameter(Rzero=0.0d0)
+
+ call dlartg(a,b,c,s,t)
+ a = t
+ b = Rzero
+ call drot(n-kr+1,R(k,kr),ldr,R(k+1,kr),ldr,c,s)
+ call drot(n ,Q(1,k) ,1 ,Q(1,k+1) ,1 ,c,s)
+
+ return
+ end
diff --git a/src/lirslv.f b/src/lirslv.f
new file mode 100644
index 0000000..f4b6361
--- /dev/null
+++ b/src/lirslv.f
@@ -0,0 +1,80 @@
+c-----------------------------------------------------------------------
+
+ 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
diff --git a/src/nleqslv.c b/src/nleqslv.c
new file mode 100644
index 0000000..bd8bad3
--- /dev/null
+++ b/src/nleqslv.c
@@ -0,0 +1,528 @@
+#include <R.h>
+#include <Rinternals.h>
+
+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 <bhh at xs4all.nl>.", 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 *xc, double *fc, int *n, int *flag)
+{
+ int i;
+ SEXP sexp_fvec;
+
+ for (i = 0; i < *n; i++)
+ REAL(OS->x)[i] = xc[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);
+ 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( LENGTH(xstart) < 1 ) error("Length initial estimates must be >= 1");
+ else 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 <Rsource>/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;
+}
diff --git a/src/nwbjac.f b/src/nwbjac.f
new file mode 100644
index 0000000..2fae777
--- /dev/null
+++ b/src/nwbjac.f
@@ -0,0 +1,185 @@
+ 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
diff --git a/src/nwbrdn.f b/src/nwbrdn.f
new file mode 100755
index 0000000..eb83f7b
--- /dev/null
+++ b/src/nwbrdn.f
@@ -0,0 +1,438 @@
+
+ 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
diff --git a/src/nwclsh.f b/src/nwclsh.f
new file mode 100755
index 0000000..03879e6
--- /dev/null
+++ b/src/nwclsh.f
@@ -0,0 +1,174 @@
+
+ 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
+ disc = b**2 - Rthree * a * slope
+ 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
diff --git a/src/nwddlg.f b/src/nwddlg.f
new file mode 100755
index 0000000..aa825cb
--- /dev/null
+++ b/src/nwddlg.f
@@ -0,0 +1,239 @@
+
+ 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
diff --git a/src/nwglsh.f b/src/nwglsh.f
new file mode 100755
index 0000000..afa3e25
--- /dev/null
+++ b/src/nwglsh.f
@@ -0,0 +1,125 @@
+
+ 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
diff --git a/src/nwmhlm.f b/src/nwmhlm.f
new file mode 100755
index 0000000..4419b6b
--- /dev/null
+++ b/src/nwmhlm.f
@@ -0,0 +1,205 @@
+
+ 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
diff --git a/src/nwnjac.f b/src/nwnjac.f
new file mode 100644
index 0000000..be9a520
--- /dev/null
+++ b/src/nwnjac.f
@@ -0,0 +1,174 @@
+ 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
diff --git a/src/nwnleq.f b/src/nwnleq.f
new file mode 100755
index 0000000..9d9ddd6
--- /dev/null
+++ b/src/nwnleq.f
@@ -0,0 +1,320 @@
+
+ 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 <flag> 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
diff --git a/src/nwnwtn.f b/src/nwnwtn.f
new file mode 100755
index 0000000..b4bb02c
--- /dev/null
+++ b/src/nwnwtn.f
@@ -0,0 +1,249 @@
+
+ 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
diff --git a/src/nwout.c b/src/nwout.c
new file mode 100755
index 0000000..cf25ffb
--- /dev/null
+++ b/src/nwout.c
@@ -0,0 +1,325 @@
+
+#include <stdio.h>
+#include <string.h>
+#include <math.h>
+
+#include <R.h>
+
+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 <jmethod>
+ */
+
+ 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");
+ }
+}
diff --git a/src/nwpdlg.f b/src/nwpdlg.f
new file mode 100755
index 0000000..046e2e5
--- /dev/null
+++ b/src/nwpdlg.f
@@ -0,0 +1,219 @@
+
+ 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
diff --git a/src/nwpure.f b/src/nwpure.f
new file mode 100755
index 0000000..8cf3175
--- /dev/null
+++ b/src/nwpure.f
@@ -0,0 +1,82 @@
+
+ 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
diff --git a/src/nwqlsh.f b/src/nwqlsh.f
new file mode 100755
index 0000000..17b02e5
--- /dev/null
+++ b/src/nwqlsh.f
@@ -0,0 +1,125 @@
+
+ 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
diff --git a/src/nwtrup.f b/src/nwtrup.f
new file mode 100755
index 0000000..415211d
--- /dev/null
+++ b/src/nwtrup.f
@@ -0,0 +1,164 @@
+
+ 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
diff --git a/src/nwutil.f b/src/nwutil.f
new file mode 100755
index 0000000..2c76786
--- /dev/null
+++ b/src/nwutil.f
@@ -0,0 +1,1028 @@
+
+ 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
diff --git a/tests/brdban.R b/tests/brdban.R
new file mode 100644
index 0000000..b19e58b
--- /dev/null
+++ b/tests/brdban.R
@@ -0,0 +1,57 @@
+# 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)
diff --git a/tests/brdban.Rout b/tests/brdban.Rout
new file mode 100644
index 0000000..f80a81d
--- /dev/null
+++ b/tests/brdban.Rout
@@ -0,0 +1,86 @@
+
+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
diff --git a/tests/brdban.Rout.save b/tests/brdban.Rout.save
new file mode 100644
index 0000000..f80a81d
--- /dev/null
+++ b/tests/brdban.Rout.save
@@ -0,0 +1,86 @@
+
+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
diff --git a/tests/brdbanded.R b/tests/brdbanded.R
new file mode 100644
index 0000000..26e0ba1
--- /dev/null
+++ b/tests/brdbanded.R
@@ -0,0 +1,59 @@
+# 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)
diff --git a/tests/brdbanded.Rout b/tests/brdbanded.Rout
new file mode 100644
index 0000000..95f2257
--- /dev/null
+++ b/tests/brdbanded.Rout
@@ -0,0 +1,98 @@
+
+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
diff --git a/tests/brdbanded.Rout.save b/tests/brdbanded.Rout.save
new file mode 100644
index 0000000..95f2257
--- /dev/null
+++ b/tests/brdbanded.Rout.save
@@ -0,0 +1,98 @@
+
+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
diff --git a/tests/brdtri.R b/tests/brdtri.R
new file mode 100644
index 0000000..33f6488
--- /dev/null
+++ b/tests/brdtri.R
@@ -0,0 +1,50 @@
+# 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)
diff --git a/tests/brdtri.Rout b/tests/brdtri.Rout
new file mode 100644
index 0000000..c377926
--- /dev/null
+++ b/tests/brdtri.Rout
@@ -0,0 +1,89 @@
+
+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
diff --git a/tests/brdtri.Rout.save b/tests/brdtri.Rout.save
new file mode 100644
index 0000000..c377926
--- /dev/null
+++ b/tests/brdtri.Rout.save
@@ -0,0 +1,89 @@
+
+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
diff --git a/tests/brdtrijac.R b/tests/brdtrijac.R
new file mode 100644
index 0000000..0054151
--- /dev/null
+++ b/tests/brdtrijac.R
@@ -0,0 +1,50 @@
+# 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)
diff --git a/tests/brdtrijac.Rout b/tests/brdtrijac.Rout
new file mode 100644
index 0000000..7055afd
--- /dev/null
+++ b/tests/brdtrijac.Rout
@@ -0,0 +1,80 @@
+
+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
diff --git a/tests/brdtrijac.Rout.save b/tests/brdtrijac.Rout.save
new file mode 100644
index 0000000..7055afd
--- /dev/null
+++ b/tests/brdtrijac.Rout.save
@@ -0,0 +1,80 @@
+
+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
diff --git a/tests/chquad.R b/tests/chquad.R
new file mode 100644
index 0000000..3e474b9
--- /dev/null
+++ b/tests/chquad.R
@@ -0,0 +1,54 @@
+
+# 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))
+}
diff --git a/tests/chquad.Rout b/tests/chquad.Rout
new file mode 100644
index 0000000..9ffe92c
--- /dev/null
+++ b/tests/chquad.Rout
@@ -0,0 +1,92 @@
+
+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
diff --git a/tests/chquad.Rout.save b/tests/chquad.Rout.save
new file mode 100644
index 0000000..9ffe92c
--- /dev/null
+++ b/tests/chquad.Rout.save
@@ -0,0 +1,92 @@
+
+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
diff --git a/tests/control-try.R b/tests/control-try.R
new file mode 100644
index 0000000..5af7091
--- /dev/null
+++ b/tests/control-try.R
@@ -0,0 +1,15 @@
+
+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)))
diff --git a/tests/control-try.Rout.save b/tests/control-try.Rout.save
new file mode 100644
index 0000000..ba007d8
--- /dev/null
+++ b/tests/control-try.Rout.save
@@ -0,0 +1,41 @@
+
+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'
+>
diff --git a/tests/dslnex.R b/tests/dslnex.R
new file mode 100644
index 0000000..c5bcb8d
--- /dev/null
+++ b/tests/dslnex.R
@@ -0,0 +1,71 @@
+
+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)
+ }
+}
diff --git a/tests/dslnex.Rout b/tests/dslnex.Rout
new file mode 100644
index 0000000..7fd386a
--- /dev/null
+++ b/tests/dslnex.Rout
@@ -0,0 +1,124 @@
+
+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
diff --git a/tests/dslnex.Rout.save b/tests/dslnex.Rout.save
new file mode 100644
index 0000000..7fd386a
--- /dev/null
+++ b/tests/dslnex.Rout.save
@@ -0,0 +1,124 @@
+
+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
diff --git a/tests/dslnexCN.R b/tests/dslnexCN.R
new file mode 100644
index 0000000..6e86833
--- /dev/null
+++ b/tests/dslnexCN.R
@@ -0,0 +1,52 @@
+
+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)
diff --git a/tests/dslnexCN.Rout b/tests/dslnexCN.Rout
new file mode 100644
index 0000000..b2e7caa
--- /dev/null
+++ b/tests/dslnexCN.Rout
@@ -0,0 +1,76 @@
+
+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
diff --git a/tests/dslnexCN.Rout.save b/tests/dslnexCN.Rout.save
new file mode 100644
index 0000000..b2e7caa
--- /dev/null
+++ b/tests/dslnexCN.Rout.save
@@ -0,0 +1,76 @@
+
+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
diff --git a/tests/dslnexHook.R b/tests/dslnexHook.R
new file mode 100644
index 0000000..20aedaf
--- /dev/null
+++ b/tests/dslnexHook.R
@@ -0,0 +1,54 @@
+
+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)
diff --git a/tests/dslnexHook.Rout b/tests/dslnexHook.Rout
new file mode 100644
index 0000000..a955176
--- /dev/null
+++ b/tests/dslnexHook.Rout
@@ -0,0 +1,99 @@
+
+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
diff --git a/tests/dslnexHook.Rout.save b/tests/dslnexHook.Rout.save
new file mode 100644
index 0000000..a955176
--- /dev/null
+++ b/tests/dslnexHook.Rout.save
@@ -0,0 +1,99 @@
+
+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
diff --git a/tests/dslnexauto.R b/tests/dslnexauto.R
new file mode 100644
index 0000000..a5e159d
--- /dev/null
+++ b/tests/dslnexauto.R
@@ -0,0 +1,71 @@
+# 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)
+ }
+}
diff --git a/tests/dslnexauto.Rout b/tests/dslnexauto.Rout
new file mode 100644
index 0000000..3b37bff
--- /dev/null
+++ b/tests/dslnexauto.Rout
@@ -0,0 +1,123 @@
+
+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
diff --git a/tests/dslnexauto.Rout.save b/tests/dslnexauto.Rout.save
new file mode 100644
index 0000000..3b37bff
--- /dev/null
+++ b/tests/dslnexauto.Rout.save
@@ -0,0 +1,123 @@
+
+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
diff --git a/tests/dslnexjacout.R b/tests/dslnexjacout.R
new file mode 100644
index 0000000..1367823
--- /dev/null
+++ b/tests/dslnexjacout.R
@@ -0,0 +1,52 @@
+# 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))
diff --git a/tests/dslnexjacout.Rout b/tests/dslnexjacout.Rout
new file mode 100644
index 0000000..1c3adf4
--- /dev/null
+++ b/tests/dslnexjacout.Rout
@@ -0,0 +1,88 @@
+
+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
diff --git a/tests/dslnexjacout.Rout.save b/tests/dslnexjacout.Rout.save
new file mode 100644
index 0000000..1c3adf4
--- /dev/null
+++ b/tests/dslnexjacout.Rout.save
@@ -0,0 +1,88 @@
+
+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
diff --git a/tests/dslnexscaled.R b/tests/dslnexscaled.R
new file mode 100644
index 0000000..e7a5c1c
--- /dev/null
+++ b/tests/dslnexscaled.R
@@ -0,0 +1,60 @@
+# 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)
+ }
+}
diff --git a/tests/dslnexscaled.Rout b/tests/dslnexscaled.Rout
new file mode 100644
index 0000000..14a8358
--- /dev/null
+++ b/tests/dslnexscaled.Rout
@@ -0,0 +1,100 @@
+
+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
diff --git a/tests/dslnexscaled.Rout.save b/tests/dslnexscaled.Rout.save
new file mode 100644
index 0000000..14a8358
--- /dev/null
+++ b/tests/dslnexscaled.Rout.save
@@ -0,0 +1,100 @@
+
+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
diff --git a/tests/singular1.R b/tests/singular1.R
new file mode 100644
index 0000000..81e19d9
--- /dev/null
+++ b/tests/singular1.R
@@ -0,0 +1,41 @@
+
+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)
+ }
+}
diff --git a/tests/singular1.Rout b/tests/singular1.Rout
new file mode 100644
index 0000000..df05ca6
--- /dev/null
+++ b/tests/singular1.Rout
@@ -0,0 +1,69 @@
+
+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
+>
diff --git a/tests/singular1.Rout.save b/tests/singular1.Rout.save
new file mode 100644
index 0000000..df05ca6
--- /dev/null
+++ b/tests/singular1.Rout.save
@@ -0,0 +1,69 @@
+
+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
+>
diff --git a/tests/singular2.R b/tests/singular2.R
new file mode 100644
index 0000000..d285531
--- /dev/null
+++ b/tests/singular2.R
@@ -0,0 +1,70 @@
+# 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)
diff --git a/tests/singular2.Rout b/tests/singular2.Rout
new file mode 100644
index 0000000..0a5709a
--- /dev/null
+++ b/tests/singular2.Rout
@@ -0,0 +1,97 @@
+
+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
diff --git a/tests/singular2.Rout.save b/tests/singular2.Rout.save
new file mode 100644
index 0000000..0a5709a
--- /dev/null
+++ b/tests/singular2.Rout.save
@@ -0,0 +1,97 @@
+
+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
diff --git a/tests/singular3.R b/tests/singular3.R
new file mode 100644
index 0000000..a28ed06
--- /dev/null
+++ b/tests/singular3.R
@@ -0,0 +1,42 @@
+
+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)
diff --git a/tests/singular3.Rout b/tests/singular3.Rout
new file mode 100644
index 0000000..d06d221
--- /dev/null
+++ b/tests/singular3.Rout
@@ -0,0 +1,67 @@
+
+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
diff --git a/tests/singular3.Rout.save b/tests/singular3.Rout.save
new file mode 100644
index 0000000..c09e5cd
--- /dev/null
+++ b/tests/singular3.Rout.save
@@ -0,0 +1,66 @@
+
+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
+>
diff --git a/tests/trig.R b/tests/trig.R
new file mode 100644
index 0000000..192bdb4
--- /dev/null
+++ b/tests/trig.R
@@ -0,0 +1,42 @@
+
+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)
diff --git a/tests/trig.Rout b/tests/trig.Rout
new file mode 100644
index 0000000..6a20b74
--- /dev/null
+++ b/tests/trig.Rout
@@ -0,0 +1,66 @@
+
+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
diff --git a/tests/trig.Rout.save b/tests/trig.Rout.save
new file mode 100644
index 0000000..6a20b74
--- /dev/null
+++ b/tests/trig.Rout.save
@@ -0,0 +1,66 @@
+
+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
diff --git a/tests/tscalargrad.R b/tests/tscalargrad.R
new file mode 100644
index 0000000..02a9ab2
--- /dev/null
+++ b/tests/tscalargrad.R
@@ -0,0 +1,26 @@
+# 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)
diff --git a/tests/tscalargrad.Rout.save b/tests/tscalargrad.Rout.save
new file mode 100644
index 0000000..5859cae
--- /dev/null
+++ b/tests/tscalargrad.Rout.save
@@ -0,0 +1,52 @@
+
+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
+>
diff --git a/tests/xcutlip1p2.R b/tests/xcutlip1p2.R
new file mode 100644
index 0000000..a2abc73
--- /dev/null
+++ b/tests/xcutlip1p2.R
@@ -0,0 +1,54 @@
+# 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)
diff --git a/tests/xcutlip1p2.Rout b/tests/xcutlip1p2.Rout
new file mode 100644
index 0000000..2367879
--- /dev/null
+++ b/tests/xcutlip1p2.Rout
@@ -0,0 +1,79 @@
+
+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
diff --git a/tests/xcutlip1p2.Rout.save b/tests/xcutlip1p2.Rout.save
new file mode 100644
index 0000000..2367879
--- /dev/null
+++ b/tests/xcutlip1p2.Rout.save
@@ -0,0 +1,79 @@
+
+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
diff --git a/tests/xnames.R b/tests/xnames.R
new file mode 100644
index 0000000..117f646
--- /dev/null
+++ b/tests/xnames.R
@@ -0,0 +1,23 @@
+
+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))
diff --git a/tests/xnames.Rout b/tests/xnames.Rout
new file mode 100644
index 0000000..a9bbed1
--- /dev/null
+++ b/tests/xnames.Rout
@@ -0,0 +1,53 @@
+
+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
diff --git a/tests/xnames.Rout.save b/tests/xnames.Rout.save
new file mode 100644
index 0000000..a9bbed1
--- /dev/null
+++ b/tests/xnames.Rout.save
@@ -0,0 +1,53 @@
+
+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
diff --git a/tests/xsearchzeros.R b/tests/xsearchzeros.R
new file mode 100644
index 0000000..d26848b
--- /dev/null
+++ b/tests/xsearchzeros.R
@@ -0,0 +1,27 @@
+# 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
diff --git a/tests/xsearchzeros.Rout b/tests/xsearchzeros.Rout
new file mode 100644
index 0000000..be473a6
--- /dev/null
+++ b/tests/xsearchzeros.Rout
@@ -0,0 +1,51 @@
+
+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
diff --git a/tests/xsearchzeros.Rout.save b/tests/xsearchzeros.Rout.save
new file mode 100644
index 0000000..be473a6
--- /dev/null
+++ b/tests/xsearchzeros.Rout.save
@@ -0,0 +1,51 @@
+
+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
diff --git a/tests/xtestnslv.R b/tests/xtestnslv.R
new file mode 100644
index 0000000..b477588
--- /dev/null
+++ b/tests/xtestnslv.R
@@ -0,0 +1,34 @@
+
+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
diff --git a/tests/xtestnslv.Rout b/tests/xtestnslv.Rout
new file mode 100644
index 0000000..02e8eba
--- /dev/null
+++ b/tests/xtestnslv.Rout
@@ -0,0 +1,94 @@
+
+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
diff --git a/tests/xtestnslv.Rout.save b/tests/xtestnslv.Rout.save
new file mode 100644
index 0000000..02e8eba
--- /dev/null
+++ b/tests/xtestnslv.Rout.save
@@ -0,0 +1,94 @@
+
+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
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-nleqslv.git
More information about the debian-science-commits
mailing list