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