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 2.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 2.0 2.0) sclfac) 24 (type (double-float 0.95 0.95) factor) 25 (ignorable zero one sclfac factor)) 26 (defun zgebal (job n a lda ilo ihi scale info) 27 (declare (type (array double-float (*)) scale) 28 (type (array f2cl-lib:complex16 (*)) a) 29 (type (f2cl-lib:integer4) info ihi ilo lda n) 30 (type (simple-string *) job)) 31 (f2cl-lib:with-multi-array-data 32 ((job character job-%data% job-%offset%) 33 (a f2cl-lib:complex16 a-%data% a-%offset%) 34 (scale double-float scale-%data% scale-%offset%)) 35 (labels ((cabs1 (cdum) 36 (+ (abs (f2cl-lib:dble cdum)) (abs (f2cl-lib:dimag cdum))))) 37 (declare (ftype (function (f2cl-lib:complex16) 38 (values double-float &rest t)) 39 cabs1)) 40 (prog ((cdum #C(0.0 0.0)) (c 0.0) (ca 0.0) (f 0.0) (g 0.0) (r 0.0) 41 (ra 0.0) (s 0.0) (sfmax1 0.0) (sfmax2 0.0) (sfmin1 0.0) 42 (sfmin2 0.0) (i 0) (ica 0) (iexc 0) (ira 0) (j 0) (k 0) (l 0) 43 (m 0) (noconv nil)) 44 (declare (type (f2cl-lib:complex16) cdum) 45 (type (double-float) c ca f g r ra s sfmax1 sfmax2 sfmin1 46 sfmin2) 47 (type (f2cl-lib:integer4) i ica iexc ira j k l m) 48 (type f2cl-lib:logical noconv)) 49 (setf info 0) 50 (cond 51 ((and (not (lsame job "N")) 52 (not (lsame job "P")) 53 (not (lsame job "S")) 54 (not (lsame job "B"))) 55 (setf info -1)) 56 ((< n 0) 57 (setf info -2)) 58 ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))) 59 (setf info -4))) 60 (cond 61 ((/= info 0) 62 (xerbla "ZGEBAL" (f2cl-lib:int-sub info)) 63 (go end_label))) 64 (setf k 1) 65 (setf l n) 66 (if (= n 0) (go label210)) 67 (cond 68 ((lsame job "N") 69 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 70 ((> i n) nil) 71 (tagbody 72 (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) 73 one) 74 label10)) 75 (go label210))) 76 (if (lsame job "S") (go label120)) 77 (go label50) 78 label20 79 (setf (f2cl-lib:fref scale-%data% (m) ((1 *)) scale-%offset%) 80 (coerce (the f2cl-lib:integer4 j) 'double-float)) 81 (if (= j m) (go label30)) 82 (zswap l 83 (f2cl-lib:array-slice a-%data% 84 f2cl-lib:complex16 85 (1 j) 86 ((1 lda) (1 *)) 87 a-%offset%) 88 1 89 (f2cl-lib:array-slice a-%data% 90 f2cl-lib:complex16 91 (1 m) 92 ((1 lda) (1 *)) 93 a-%offset%) 94 1) 95 (zswap (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1) 96 (f2cl-lib:array-slice a-%data% 97 f2cl-lib:complex16 98 (j k) 99 ((1 lda) (1 *)) 100 a-%offset%) 101 lda 102 (f2cl-lib:array-slice a-%data% 103 f2cl-lib:complex16 104 (m k) 105 ((1 lda) (1 *)) 106 a-%offset%) 107 lda) 108 label30 109 (f2cl-lib:computed-goto (label40 label80) iexc) 110 label40 111 (if (= l 1) (go label210)) 112 (setf l (f2cl-lib:int-sub l 1)) 113 label50 114 (f2cl-lib:fdo (j l (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) 115 ((> j 1) nil) 116 (tagbody 117 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 118 ((> i l) nil) 119 (tagbody 120 (if (= i j) (go label60)) 121 (if 122 (or 123 (/= 124 (f2cl-lib:dble 125 (f2cl-lib:fref a-%data% 126 (j i) 127 ((1 lda) (1 *)) 128 a-%offset%)) 129 zero) 130 (/= 131 (f2cl-lib:dimag 132 (f2cl-lib:fref a-%data% 133 (j i) 134 ((1 lda) (1 *)) 135 a-%offset%)) 136 zero)) 137 (go label70)) 138 label60)) 139 (setf m l) 140 (setf iexc 1) 141 (go label20) 142 label70)) 143 (go label90) 144 label80 145 (setf k (f2cl-lib:int-add k 1)) 146 label90 147 (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1)) 148 ((> j l) nil) 149 (tagbody 150 (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1)) 151 ((> i l) nil) 152 (tagbody 153 (if (= i j) (go label100)) 154 (if 155 (or 156 (/= 157 (f2cl-lib:dble 158 (f2cl-lib:fref a-%data% 159 (i j) 160 ((1 lda) (1 *)) 161 a-%offset%)) 162 zero) 163 (/= 164 (f2cl-lib:dimag 165 (f2cl-lib:fref a-%data% 166 (i j) 167 ((1 lda) (1 *)) 168 a-%offset%)) 169 zero)) 170 (go label110)) 171 label100)) 172 (setf m k) 173 (setf iexc 2) 174 (go label20) 175 label110)) 176 label120 177 (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1)) 178 ((> i l) nil) 179 (tagbody 180 (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) 181 one) 182 label130)) 183 (if (lsame job "P") (go label210)) 184 (setf sfmin1 (/ (dlamch "S") (dlamch "P"))) 185 (setf sfmax1 (/ one sfmin1)) 186 (setf sfmin2 (* sfmin1 sclfac)) 187 (setf sfmax2 (/ one sfmin2)) 188 label140 189 (setf noconv f2cl-lib:%false%) 190 (f2cl-lib:fdo (i k (f2cl-lib:int-add i 1)) 191 ((> i l) nil) 192 (tagbody 193 (setf c zero) 194 (setf r zero) 195 (f2cl-lib:fdo (j k (f2cl-lib:int-add j 1)) 196 ((> j l) nil) 197 (tagbody 198 (if (= j i) (go label150)) 199 (setf c 200 (+ c 201 (cabs1 202 (f2cl-lib:fref a-%data% 203 (j i) 204 ((1 lda) (1 *)) 205 a-%offset%)))) 206 (setf r 207 (+ r 208 (cabs1 209 (f2cl-lib:fref a-%data% 210 (i j) 211 ((1 lda) (1 *)) 212 a-%offset%)))) 213 label150)) 214 (setf ica 215 (izamax l 216 (f2cl-lib:array-slice a-%data% 217 f2cl-lib:complex16 218 (1 i) 219 ((1 lda) (1 *)) 220 a-%offset%) 221 1)) 222 (setf ca 223 (abs 224 (f2cl-lib:fref a-%data% 225 (ica i) 226 ((1 lda) (1 *)) 227 a-%offset%))) 228 (setf ira 229 (izamax (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1) 230 (f2cl-lib:array-slice a-%data% 231 f2cl-lib:complex16 232 (i k) 233 ((1 lda) (1 *)) 234 a-%offset%) 235 lda)) 236 (setf ra 237 (abs 238 (f2cl-lib:fref a-%data% 239 (i 240 (f2cl-lib:int-sub 241 (f2cl-lib:int-add ira k) 242 1)) 243 ((1 lda) (1 *)) 244 a-%offset%))) 245 (if (or (= c zero) (= r zero)) (go label200)) 246 (setf g (/ r sclfac)) 247 (setf f one) 248 (setf s (+ c r)) 249 label160 250 (if 251 (or (>= c g) (>= (max f c ca) sfmax2) (<= (min r g ra) sfmin2)) 252 (go label170)) 253 (cond 254 ((disnan (+ c f ca r g ra)) 255 (setf info -3) 256 (xerbla "ZGEBAL" (f2cl-lib:int-sub info)) 257 (go end_label))) 258 (setf f (* f sclfac)) 259 (setf c (* c sclfac)) 260 (setf ca (* ca sclfac)) 261 (setf r (/ r sclfac)) 262 (setf g (/ g sclfac)) 263 (setf ra (/ ra sclfac)) 264 (go label160) 265 label170 266 (setf g (/ c sclfac)) 267 label180 268 (if 269 (or (< g r) (>= (max r ra) sfmax2) (<= (min f c g ca) sfmin2)) 270 (go label190)) 271 (setf f (/ f sclfac)) 272 (setf c (/ c sclfac)) 273 (setf g (/ g sclfac)) 274 (setf ca (/ ca sclfac)) 275 (setf r (* r sclfac)) 276 (setf ra (* ra sclfac)) 277 (go label180) 278 label190 279 (if (>= (+ c r) (* factor s)) (go label200)) 280 (cond 281 ((and (< f one) (< (f2cl-lib:fref scale (i) ((1 *))) one)) 282 (if 283 (<= 284 (* f 285 (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%)) 286 sfmin1) 287 (go label200)))) 288 (cond 289 ((and (> f one) (> (f2cl-lib:fref scale (i) ((1 *))) one)) 290 (if 291 (>= (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) 292 (/ sfmax1 f)) 293 (go label200)))) 294 (setf g (/ one f)) 295 (setf (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) 296 (* 297 (f2cl-lib:fref scale-%data% (i) ((1 *)) scale-%offset%) 298 f)) 299 (setf noconv f2cl-lib:%true%) 300 (zdscal (f2cl-lib:int-add (f2cl-lib:int-sub n k) 1) g 301 (f2cl-lib:array-slice a-%data% 302 f2cl-lib:complex16 303 (i k) 304 ((1 lda) (1 *)) 305 a-%offset%) 306 lda) 307 (zdscal l f 308 (f2cl-lib:array-slice a-%data% 309 f2cl-lib:complex16 310 (1 i) 311 ((1 lda) (1 *)) 312 a-%offset%) 313 1) 314 label200)) 315 (if noconv (go label140)) 316 label210 317 (setf ilo k) 318 (setf ihi l) 319 (go end_label) 320 end_label 321 (return (values nil nil nil nil ilo ihi nil info))))))) 322 323(in-package #-gcl #:cl-user #+gcl "CL-USER") 324#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 325(eval-when (:load-toplevel :compile-toplevel :execute) 326 (setf (gethash 'fortran-to-lisp::zgebal 327 fortran-to-lisp::*f2cl-function-info*) 328 (fortran-to-lisp::make-f2cl-finfo 329 :arg-types '((simple-string) (fortran-to-lisp::integer4) 330 (array fortran-to-lisp::complex16 (*)) 331 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 332 (fortran-to-lisp::integer4) (array double-float (*)) 333 (fortran-to-lisp::integer4)) 334 :return-values '(nil nil nil nil fortran-to-lisp::ilo 335 fortran-to-lisp::ihi nil fortran-to-lisp::info) 336 :calls '(fortran-to-lisp::zdscal fortran-to-lisp::disnan 337 fortran-to-lisp::izamax fortran-to-lisp::dlamch 338 fortran-to-lisp::zswap fortran-to-lisp::xerbla 339 fortran-to-lisp::lsame)))) 340 341