From 10ad01cecff6fef58fd9b8678b122172cc84a7f2 Mon Sep 17 00:00:00 2001
From: Alex Lang <me@alang.ca>
Date: Wed, 8 May 2013 14:33:24 +0900
Subject: Implement uniRootJ for one-dimensional root-finding with derivatives

---
 lib/Numeric/GSL/Root.hs   | 37 ++++++++++++++++++++--
 lib/Numeric/GSL/gsl-aux.c | 79 +++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 114 insertions(+), 2 deletions(-)

(limited to 'lib')

diff --git a/lib/Numeric/GSL/Root.hs b/lib/Numeric/GSL/Root.hs
index 25ec5f5..6da15e5 100644
--- a/lib/Numeric/GSL/Root.hs
+++ b/lib/Numeric/GSL/Root.hs
@@ -46,6 +46,7 @@ main = do
 
 module Numeric.GSL.Root (
     uniRoot, UniRootMethod(..),
+    uniRootJ, UniRootMethodJ(..),
     root, RootMethod(..),
     rootJ, RootMethodJ(..),
 ) where
@@ -87,6 +88,38 @@ uniRootGen m f xl xu epsrel maxit = unsafePerformIO $ do
 foreign import ccall safe "root"
     c_root:: CInt -> FunPtr (Double -> Double) -> Double -> CInt -> Double -> Double -> TM
 
+-------------------------------------------------------------------------
+data UniRootMethodJ = UNewton
+                    | Secant
+                    | Steffenson
+                    deriving (Enum, Eq, Show, Bounded)
+
+uniRootJ :: UniRootMethodJ
+        -> Double
+        -> Int
+        -> (Double -> Double)
+        -> (Double -> Double)
+        -> Double
+        -> (Double, Matrix Double)
+uniRootJ method epsrel maxit fun dfun x = uniRootJGen (fi (fromEnum method)) fun
+    dfun x epsrel maxit
+
+uniRootJGen m f df x epsrel maxit = unsafePerformIO $ do
+    fp <- mkDoublefun f
+    dfp <- mkDoublefun df
+    rawpath <- createMIO maxit 2
+                         (c_rootj m fp dfp epsrel (fi maxit) x)
+                         "rootj"
+    let it = round (rawpath @@> (maxit-1,0))
+        path = takeRows it rawpath
+        [sol] = toLists $ dropRows (it-1) path
+    freeHaskellFunPtr fp
+    return (sol !! 1, path)
+
+foreign import ccall safe "rootj"
+    c_rootj :: CInt -> FunPtr (Double -> Double) -> FunPtr (Double -> Double)
+            -> Double -> CInt -> Double -> TM
+
 -------------------------------------------------------------------------
 
 data RootMethod = Hybrids
@@ -151,7 +184,7 @@ rootJGen m f jac xi epsabs maxit = unsafePerformIO $ do
     jp <- mkVecMatfun (aux_vTom (checkdim2 n . fromLists . jac . toList))
     rawpath <- vec xiv $ \xiv' ->
                    createMIO maxit (2*n+1)
-                         (c_rootj m fp jp epsabs (fi maxit) // xiv')
+                         (c_multirootj m fp jp epsabs (fi maxit) // xiv')
                          "multiroot"
     let it = round (rawpath @@> (maxit-1,0))
         path = takeRows it rawpath
@@ -161,7 +194,7 @@ rootJGen m f jac xi epsabs maxit = unsafePerformIO $ do
     return (take n $ drop 1 sol, path)
 
 foreign import ccall safe "multirootj"
-    c_rootj:: CInt -> FunPtr TVV -> FunPtr TVM -> Double -> CInt -> TVM
+    c_multirootj:: CInt -> FunPtr TVV -> FunPtr TVM -> Double -> CInt -> TVM
 
 -------------------------------------------------------
 
diff --git a/lib/Numeric/GSL/gsl-aux.c b/lib/Numeric/GSL/gsl-aux.c
index 27ffbdc..e727c91 100644
--- a/lib/Numeric/GSL/gsl-aux.c
+++ b/lib/Numeric/GSL/gsl-aux.c
@@ -1104,6 +1104,85 @@ int root(int method, double f(double),
     OK
 }
 
+typedef struct {
+    double (*f)(double);
+    double (*jf)(double);
+} uniTfjf;
+
+double f_aux_uni(double x, void *pars) {
+    uniTfjf * fjf = ((uniTfjf*) pars);
+    return (fjf->f)(x);
+}
+
+double jf_aux_uni(double x, void * pars) {
+    uniTfjf * fjf = ((uniTfjf*) pars);
+    return (fjf->jf)(x);
+}
+
+void fjf_aux_uni(double x, void * pars, double * f, double * g) {
+    *f = f_aux_uni(x,pars);
+    *g = jf_aux_uni(x,pars);
+}
+
+int rootj(int method, double f(double),
+          double df(double),
+         double epsrel, int maxit,
+         double x, RMAT(sol)) {
+    REQUIRES(solr == maxit && solc == 2,BAD_SIZE);
+    DEBUGMSG("root_fjf");
+    gsl_function_fdf my_func;
+    // extract function from pars
+    my_func.f = f_aux_uni;
+    my_func.df = jf_aux_uni;
+    my_func.fdf = fjf_aux_uni;
+    uniTfjf stfjf;
+    stfjf.f = f;
+    stfjf.jf = df;
+    my_func.params = &stfjf;
+    size_t iter = 0;
+    int status;
+    const gsl_root_fdfsolver_type *T;
+    gsl_root_fdfsolver *s;
+    // Starting point
+    switch(method) {
+        case 0 : {T = gsl_root_fdfsolver_newton;; break; }
+        case 1 : {T = gsl_root_fdfsolver_secant; break; }
+        case 2 : {T = gsl_root_fdfsolver_steffenson; break; }
+        default: ERROR(BAD_CODE);
+    }
+    s = gsl_root_fdfsolver_alloc (T);
+
+    gsl_root_fdfsolver_set (s, &my_func, x);
+
+    do {
+           double x0;
+           status = gsl_root_fdfsolver_iterate (s);
+           x0 = x;
+           x = gsl_root_fdfsolver_root(s);
+           solp[iter*solc+0] = iter+1;
+           solp[iter*solc+1] = x;
+
+           iter++;
+           if (status)   /* check if solver is stuck */
+             break;
+
+           status =
+               gsl_root_test_delta (x, x0, 0, epsrel);
+        }
+        while (status == GSL_CONTINUE && iter < maxit);
+
+    int i;
+    for (i=iter; i<solr; i++) {
+        solp[i*solc+0] = iter;
+        solp[i*solc+1]=0.;
+    }
+    gsl_root_fdfsolver_free(s);
+    OK
+}
+
+
+//---------------------------------------------------------------
+
 typedef void TrawfunV(int, double*, int, double*);
 
 int only_f_aux_multiroot(const gsl_vector*x, void *pars, gsl_vector*y) {
-- 
cgit v1.2.3