Function: math-search-root

math-search-root is a byte-compiled function defined in calcalg3.el.gz.

Signature

(math-search-root EXPR DERIV LOW VLOW HIGH VHIGH)

Source Code

;; Defined in /usr/src/emacs/lisp/calc/calcalg3.el.gz
(defun math-search-root (expr deriv low vlow high vhigh)
  (let (found)
    (if math-root-widen
	(let ((iters 0)
	      (iterlim (if (eq math-root-widen 'point)
			   (+ calc-internal-prec 10)
			 20))
	      (factor (if (eq math-root-widen 'point)
			  '(float 9 0)
			'(float 16 -1)))
	      (prev nil) vprev waslow
	      diff)
	  (while (or (and (math-posp vlow) (math-posp vhigh))
		     (and (math-negp vlow) (math-negp vhigh)))
	    (math-working "widen" (list 'intv 0 low high))
	    (if (> (setq iters (1+ iters)) iterlim)
		(math-reject-arg (list 'intv 0 low high)
				 "*Unable to bracket root"))
	    (if (= iters calc-internal-prec)
		(setq factor '(float 16 -1)))
	    (setq diff (math-mul-float (math-sub-float high low) factor))
	    (if (Math-zerop diff)
		(setq high (calcFunc-incr high 10))
	      (if (math-lessp-float (math-abs vlow) (math-abs vhigh))
		  (setq waslow t
			prev low
			low (math-sub low diff)
			var-DUMMY low
			vprev vlow
			vlow (math-evaluate-expr expr))
		(setq waslow nil
		      prev high
		      high (math-add high diff)
		      var-DUMMY high
		      vprev vhigh
		      vhigh (math-evaluate-expr expr)))))
	  (if prev
	      (if waslow
		  (setq high prev vhigh vprev)
		(setq low prev vlow vprev)))
	  (setq found t))
      (or (Math-realp vlow)
	  (math-reject-arg vlow 'realp))
      (or (Math-realp vhigh)
	  (math-reject-arg vhigh 'realp))
      (let ((xvals (list low high))
	    (yvals (list vlow vhigh))
	    (pos (Math-posp vlow))
	    (levels 0)
	    (step (math-sub-float high low))
	    xp yp var-DUMMY)
	(while (and (<= (setq levels (1+ levels)) 5)
		    (not found))
	  (setq xp xvals
		yp yvals
		step (math-mul-float step '(float 497 -3)))
	  (while (and (cdr xp) (not found))
	    (if (Math-realp (car yp))
		(setq low (car xp)
		      vlow (car yp)))
	    (setq high (math-add-float (car xp) step)
		  var-DUMMY high
		  vhigh (math-evaluate-expr expr))
	    (math-working "search" high)
	    (if (and (Math-realp vhigh)
		     (eq (math-negp vhigh) pos))
		(setq found t)
	      (setcdr xp (cons high (cdr xp)))
	      (setcdr yp (cons vhigh (cdr yp)))
	      (setq xp (cdr (cdr xp))
		    yp (cdr (cdr yp))))))))
    (if found
	(if (Math-zerop vhigh)
	    (list 'vec high vhigh)
	  (if (Math-zerop vlow)
	      (list 'vec low vlow)
	    (if deriv
		(math-newton-search-root expr deriv nil nil nil nil
					 low vlow high vhigh)
	      (math-bisect-root expr low vlow high vhigh))))
      (math-reject-arg (list 'intv 3 low high)
		       "*Unable to find a sign change in this interval"))))