share/hompack/lisp/root.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   3 ;;;  "f2cl2.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   4 ;;;  "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   5 ;;;  "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   6 ;;;  "f2cl5.l,v 95098eb54f13 2013/04/01 00:45:16 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v 1409c1352feb 2013/03/24 20:44:50 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp snapshot-2020-04 (21D Unicode)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':array)
  14 ;;;           (:array-slicing t) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package "HOMPACK")
  18
  19
  20 (let ((ic 0)
  21       (kount 0)
  22       (a 0.0)
  23       (acbs 0.0)
  24       (acmb 0.0)
  25       (ae 0.0)
  26       (cmb 0.0)
  27       (fa 0.0)
  28       (fb 0.0)
  29       (fc 0.0)
  30       (fx 0.0)
  31       (p 0.0)
  32       (q 0.0)
  33       (re 0.0)
  34       (tol 0.0)
  35       (u 0.0))
  36   (declare (type (f2cl-lib:integer4) ic kount)
  37            (type (double-float) a acbs acmb ae cmb fa fb fc fx p q re tol u))
  38   (defun root (t$ ft b c relerr abserr iflag)
  39     (declare (type (f2cl-lib:integer4) iflag)
  40              (type (double-float) abserr relerr c b ft t$))
  41     (prog ()
  42       (declare)
  43       (if (>= iflag 0) (go label100))
  44       (setf iflag (abs iflag))
  45       (f2cl-lib:computed-goto (label200 label300 label400) iflag)
  46      label100
  47       (setf u (f2cl-lib:d1mach 4))
  48       (setf re (max relerr u))
  49       (setf ae (max abserr 0.0))
  50       (setf ic 0)
  51       (setf acbs (abs (- b c)))
  52       (setf a c)
  53       (setf t$ a)
  54       (setf iflag -1)
  55       (go end_label)
  56      label200
  57       (setf fa ft)
  58       (setf t$ b)
  59       (setf iflag -2)
  60       (go end_label)
  61      label300
  62       (setf fb ft)
  63       (setf fc fa)
  64       (setf kount 2)
  65       (setf fx (max (abs fb) (abs fc)))
  66      label1
  67       (if (>= (abs fc) (abs fb)) (go label2))
  68       (setf a b)
  69       (setf fa fb)
  70       (setf b c)
  71       (setf fb fc)
  72       (setf c a)
  73       (setf fc fa)
  74      label2
  75       (setf cmb (* 0.5f0 (- c b)))
  76       (setf acmb (abs cmb))
  77       (setf tol (+ (* re (abs b)) ae))
  78       (if (<= acmb tol) (go label8))
  79       (if (>= kount 500) (go label12))
  80       (setf p (* (- b a) fb))
  81       (setf q (- fa fb))
  82       (if (>= p 0.0f0) (go label3))
  83       (setf p (- p))
  84       (setf q (- q))
  85      label3
  86       (setf a b)
  87       (setf fa fb)
  88       (setf ic (f2cl-lib:int-add ic 1))
  89       (if (< ic 4) (go label4))
  90       (if (>= (* 8.0f0 acmb) acbs) (go label6))
  91       (setf ic 0)
  92       (setf acbs acmb)
  93      label4
  94       (if (> p (* (abs q) tol)) (go label5))
  95       (setf b (+ b (f2cl-lib:sign tol cmb)))
  96       (go label7)
  97      label5
  98       (if (>= p (* cmb q)) (go label6))
  99       (setf b (+ b (/ p q)))
 100       (go label7)
 101      label6
 102       (setf b (* 0.5f0 (+ c b)))
 103      label7
 104       (setf t$ b)
 105       (setf iflag -3)
 106       (go end_label)
 107      label400
 108       (setf fb ft)
 109       (if (= fb 0.0f0) (go label9))
 110       (setf kount (f2cl-lib:int-add kount 1))
 111       (if (/= (f2cl-lib:sign 1.0 fb) (f2cl-lib:sign 1.0 fc)) (go label1))
 112       (setf c a)
 113       (setf fc fa)
 114       (go label1)
 115      label8
 116       (if (= (f2cl-lib:sign 1.0 fb) (f2cl-lib:sign 1.0 fc)) (go label11))
 117       (if (> (abs fb) fx) (go label10))
 118       (setf iflag 1)
 119       (go end_label)
 120      label9
 121       (setf iflag 2)
 122       (go end_label)
 123      label10
 124       (setf iflag 3)
 125       (go end_label)
 126      label11
 127       (setf iflag 4)
 128       (go end_label)
 129      label12
 130       (setf iflag 5)
 131       (go end_label)
 132      end_label
 133       (return (values t$ nil b c nil nil iflag)))))
 134
 135 (in-package #:cl-user)
 136 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 137 (eval-when (:load-toplevel :compile-toplevel :execute)
 138   (setf (gethash 'fortran-to-lisp::root fortran-to-lisp::*f2cl-function-info*)
 139           (fortran-to-lisp::make-f2cl-finfo
 140            :arg-types '((double-float) (double-float) (double-float)
 141                         (double-float) (double-float) (double-float)
 142                         (fortran-to-lisp::integer4))
 143            :return-values '(fortran-to-lisp::t$ nil fortran-to-lisp::b
 144                             fortran-to-lisp::c nil nil fortran-to-lisp::iflag)
 145            :calls '(fortran-to-lisp::d1mach))))
 146