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