1;;; Compiled by f2cl version:
2;;; ("f2cl1.l,v 2edcbd958861 2012/05/30 03:34:52 toy $"
3;;;  "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
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 3fe93de3be82 2012/05/06 02:17:14 toy $"
7;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
8;;;  "macros.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $")
9
10;;; Using Lisp CMU Common Lisp 20d (20D 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 :lapack)
18
19
20(let* ((zero 0.0) (one 1.0) (sclfac 8.0) (factor 0.95))
21  (declare (type (double-float 0.0 0.0) zero)
22           (type (double-float 1.0 1.0) one)
23           (type (double-float 8.0 8.0) sclfac)
24           (type (double-float 0.95 0.95) factor)
25           (ignorable zero one sclfac factor))
26  (defun dgebal (job n a lda ilo ihi scale info)
27    (declare (type (array double-float (*)) scale a)
28             (type (f2cl-lib:integer4) info ihi ilo lda n)
29             (type (simple-string *) job))
30    (f2cl-lib:with-multi-array-data
31        ((job character job-%data% job-%offset%)
32         (a double-float a-%data% a-%offset%)
33         (scale double-float scale-%data% scale-%offset%))
34      (prog ((c 0.0) (ca 0.0) (f 0.0) (g 0.0) (r 0.0) (ra 0.0) (s 0.0)
35             (sfmax1 0.0) (sfmax2 0.0) (sfmin1 0.0) (sfmin2 0.0) (i 0) (ica 0)
36             (iexc 0) (ira 0) (j 0) (k 0) (l 0) (m 0) (noconv nil))
37        (declare (type (double-float) c ca f g r ra s sfmax1 sfmax2 sfmin1
38                                      sfmin2)
39                 (type (f2cl-lib:integer4) i ica iexc ira j k l m)
40                 (type f2cl-lib:logical noconv))
41        (setf info 0)
42        (cond
43          ((and (not (lsame job "N"))
44                (not (lsame job "P"))
45                (not (lsame job "S"))
46                (not (lsame job "B")))
47           (setf info -1))
48          ((< n 0)
49           (setf info -2))
50          ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
51           (setf info -4)))
52        (cond
53          ((/= info 0)
54           (xerbla "DGEBAL" (f2cl-lib:int-sub info))
55           (go end_label)))
56        (setf k 1)
57        (setf l n)
58        (if (= n 0) (go label210))
59        (cond
60          ((lsame job "N")
61           (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
62                         ((> i n) nil)
63             (tagbody
64               (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%)
65                       one)
66              label10))
67           (go label210)))
68        (if (lsame job "S") (go label120))
69        (go label50)
70       label20
71        (setf (f2cl-lib:fref scale-%data% (m) ((1 *)) scale-%offset%)
72                (coerce (the f2cl-lib:integer4 j) 'double-float))
73        (if (= j m) (go label30))
74        (dswap l
75         (f2cl-lib:array-slice a-%data%
76                               double-float
77                               (1 j)
78                               ((1 lda) (1 *))
79                               a-%offset%)
80         1
81         (f2cl-lib:array-slice a-%data%
82                               double-float
83                               (1 m)
84                               ((1 lda) (1 *))
85                               a-%offset%)
86         1)
87        (dswap (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1)
88         (f2cl-lib:array-slice a-%data%
89                               double-float
90                               (j k)
91                               ((1 lda) (1 *))
92                               a-%offset%)
93         lda
94         (f2cl-lib:array-slice a-%data%
95                               double-float
96                               (m k)
97                               ((1 lda) (1 *))
98                               a-%offset%)
99         lda)
100       label30
101        (f2cl-lib:computed-goto (label40 label80) iexc)
102       label40
103        (if (= l 1) (go label210))
104        (setf l (f2cl-lib:int-sub l 1))
105       label50
106        (f2cl-lib:fdo (j l (f2cl-lib:int-add j (f2cl-lib:int-sub 1)))
107                      ((> j 1) nil)
108          (tagbody
109            (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
110                          ((> i l) nil)
111              (tagbody
112                (if (= i j) (go label60))
113                (if
114                 (/= (f2cl-lib:fref a-%data% (j i) ((1 lda) (1 *)) a-%offset%)
115                     zero)
116                 (go label70))
117               label60))
118            (setf m l)
119            (setf iexc 1)
120            (go label20)
121           label70))
122        (go label90)
123       label80
124        (setf k (f2cl-lib:int-add k 1))
125       label90
126        (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1))
127                      ((> j l) nil)
128          (tagbody
129            (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1))
130                          ((> i l) nil)
131              (tagbody
132                (if (= i j) (go label100))
133                (if
134                 (/= (f2cl-lib:fref a-%data% (i j) ((1 lda) (1 *)) a-%offset%)
135                     zero)
136                 (go label110))
137               label100))
138            (setf m k)
139            (setf iexc 2)
140            (go label20)
141           label110))
142       label120
143        (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1))
144                      ((> i l) nil)
145          (tagbody
146            (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) one)
147           label130))
148        (if (lsame job "P") (go label210))
149        (setf sfmin1 (/ (dlamch "S") (dlamch "P")))
150        (setf sfmax1 (/ one sfmin1))
151        (setf sfmin2 (* sfmin1 sclfac))
152        (setf sfmax2 (/ one sfmin2))
153       label140
154        (setf noconv f2cl-lib:%false%)
155        (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1))
156                      ((> i l) nil)
157          (tagbody
158            (setf c zero)
159            (setf r zero)
160            (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1))
161                          ((> j l) nil)
162              (tagbody
163                (if (= j i) (go label150))
164                (setf c
165                        (+ c
166                           (abs
167                            (f2cl-lib:fref a-%data%
168                                           (j i)
169                                           ((1 lda) (1 *))
170                                           a-%offset%))))
171                (setf r
172                        (+ r
173                           (abs
174                            (f2cl-lib:fref a-%data%
175                                           (i j)
176                                           ((1 lda) (1 *))
177                                           a-%offset%))))
178               label150))
179            (setf ica
180                    (idamax l
181                     (f2cl-lib:array-slice a-%data%
182                                           double-float
183                                           (1 i)
184                                           ((1 lda) (1 *))
185                                           a-%offset%)
186                     1))
187            (setf ca
188                    (abs
189                     (f2cl-lib:fref a-%data%
190                                    (ica i)
191                                    ((1 lda) (1 *))
192                                    a-%offset%)))
193            (setf ira
194                    (idamax (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1)
195                     (f2cl-lib:array-slice a-%data%
196                                           double-float
197                                           (i k)
198                                           ((1 lda) (1 *))
199                                           a-%offset%)
200                     lda))
201            (setf ra
202                    (abs
203                     (f2cl-lib:fref a-%data%
204                                    (i
205                                     (f2cl-lib:int-sub (f2cl-lib:int-add ira k)
206                                                       1))
207                                    ((1 lda) (1 *))
208                                    a-%offset%)))
209            (if (or (= c zero) (= r zero)) (go label200))
210            (setf g (/ r sclfac))
211            (setf f one)
212            (setf s (+ c r))
213           label160
214            (if (or (>= c g) (>= (max f c ca) sfmax2) (<= (min r g ra) sfmin2))
215                (go label170))
216            (setf f (* f sclfac))
217            (setf c (* c sclfac))
218            (setf ca (* ca sclfac))
219            (setf r (/ r sclfac))
220            (setf g (/ g sclfac))
221            (setf ra (/ ra sclfac))
222            (go label160)
223           label170
224            (setf g (/ c sclfac))
225           label180
226            (if (or (< g r) (>= (max r ra) sfmax2) (<= (min f c g ca) sfmin2))
227                (go label190))
228            (setf f (/ f sclfac))
229            (setf c (/ c sclfac))
230            (setf g (/ g sclfac))
231            (setf ca (/ ca sclfac))
232            (setf r (* r sclfac))
233            (setf ra (* ra sclfac))
234            (go label180)
235           label190
236            (if (>= (+ c r) (* factor s)) (go label200))
237            (cond
238              ((and (< f one) (< (f2cl-lib:fref scale (i) ((1 *))) one))
239               (if
240                (<=
241                 (* f (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%))
242                 sfmin1)
243                (go label200))))
244            (cond
245              ((and (> f one) (> (f2cl-lib:fref scale (i) ((1 *))) one))
246               (if
247                (>= (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%)
248                    (/ sfmax1 f))
249                (go label200))))
250            (setf g (/ one f))
251            (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%)
252                    (* (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%)
253                       f))
254            (setf noconv f2cl-lib:%true%)
255            (dscal (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1) g
256             (f2cl-lib:array-slice a-%data%
257                                   double-float
258                                   (i k)
259                                   ((1 lda) (1 *))
260                                   a-%offset%)
261             lda)
262            (dscal l f
263             (f2cl-lib:array-slice a-%data%
264                                   double-float
265                                   (1 i)
266                                   ((1 lda) (1 *))
267                                   a-%offset%)
268             1)
269           label200))
270        (if noconv (go label140))
271       label210
272        (setf ilo k)
273        (setf ihi l)
274        (go end_label)
275       end_label
276        (return (values nil nil nil nil ilo ihi nil info))))))
277
278(in-package #-gcl #:cl-user #+gcl "CL-USER")
279#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
280(eval-when (:load-toplevel :compile-toplevel :execute)
281  (setf (gethash 'fortran-to-lisp::dgebal
282                 fortran-to-lisp::*f2cl-function-info*)
283          (fortran-to-lisp::make-f2cl-finfo
284           :arg-types '((simple-string) (fortran-to-lisp::integer4)
285                        (array double-float (*)) (fortran-to-lisp::integer4)
286                        (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
287                        (array double-float (*)) (fortran-to-lisp::integer4))
288           :return-values '(nil nil nil nil fortran-to-lisp::ilo
289                            fortran-to-lisp::ihi nil fortran-to-lisp::info)
290           :calls '(fortran-to-lisp::dscal fortran-to-lisp::idamax
291                    fortran-to-lisp::dlamch fortran-to-lisp::dswap
292                    fortran-to-lisp::xerbla fortran-to-lisp::lsame))))
293
294