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)) 21 (declare (type (double-float 0.0 0.0) zero) 22 (type (double-float 1.0 1.0) one) 23 (ignorable zero one)) 24 (defun dlascl (type kl ku cfrom cto m n a lda info) 25 (declare (type (array double-float (*)) a) 26 (type (double-float) cto cfrom) 27 (type (f2cl-lib:integer4) info lda n m ku kl) 28 (type (simple-string *) type)) 29 (f2cl-lib:with-multi-array-data 30 ((type character type-%data% type-%offset%) 31 (a double-float a-%data% a-%offset%)) 32 (prog ((bignum 0.0) (cfrom1 0.0) (cfromc 0.0) (cto1 0.0) (ctoc 0.0) 33 (mul 0.0) (smlnum 0.0) (i 0) (itype 0) (j 0) (k1 0) (k2 0) (k3 0) 34 (k4 0) (done nil)) 35 (declare (type (double-float) bignum cfrom1 cfromc cto1 ctoc mul 36 smlnum) 37 (type (f2cl-lib:integer4) i itype j k1 k2 k3 k4) 38 (type f2cl-lib:logical done)) 39 (setf info 0) 40 (cond 41 ((lsame type "G") 42 (setf itype 0)) 43 ((lsame type "L") 44 (setf itype 1)) 45 ((lsame type "U") 46 (setf itype 2)) 47 ((lsame type "H") 48 (setf itype 3)) 49 ((lsame type "B") 50 (setf itype 4)) 51 ((lsame type "Q") 52 (setf itype 5)) 53 ((lsame type "Z") 54 (setf itype 6)) 55 (t 56 (setf itype -1))) 57 (cond 58 ((= itype (f2cl-lib:int-sub 1)) 59 (setf info -1)) 60 ((= cfrom zero) 61 (setf info -4)) 62 ((< m 0) 63 (setf info -6)) 64 ((or (< n 0) (and (= itype 4) (/= n m)) (and (= itype 5) (/= n m))) 65 (setf info -7)) 66 ((and (<= itype 3) 67 (< lda 68 (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))) 69 (setf info -9)) 70 ((>= itype 4) 71 (cond 72 ((or (< kl 0) 73 (> kl 74 (max 75 (the f2cl-lib:integer4 76 (f2cl-lib:int-add m (f2cl-lib:int-sub 1))) 77 (the f2cl-lib:integer4 0)))) 78 (setf info -2)) 79 ((or (< ku 0) 80 (> ku 81 (max 82 (the f2cl-lib:integer4 83 (f2cl-lib:int-add n (f2cl-lib:int-sub 1))) 84 (the f2cl-lib:integer4 0))) 85 (and (or (= itype 4) (= itype 5)) (/= kl ku))) 86 (setf info -3)) 87 ((or (and (= itype 4) (< lda (f2cl-lib:int-add kl 1))) 88 (and (= itype 5) (< lda (f2cl-lib:int-add ku 1))) 89 (and (= itype 6) 90 (< lda (f2cl-lib:int-add (f2cl-lib:int-mul 2 kl) ku 1)))) 91 (setf info -9))))) 92 (cond 93 ((/= info 0) 94 (xerbla "DLASCL" (f2cl-lib:int-sub info)) 95 (go end_label))) 96 (if (or (= n 0) (= m 0)) (go end_label)) 97 (setf smlnum (dlamch "S")) 98 (setf bignum (/ one smlnum)) 99 (setf cfromc cfrom) 100 (setf ctoc cto) 101 label10 102 (setf cfrom1 (* cfromc smlnum)) 103 (setf cto1 (/ ctoc bignum)) 104 (cond 105 ((and (> (abs cfrom1) (abs ctoc)) (/= ctoc zero)) 106 (setf mul smlnum) 107 (setf done f2cl-lib:%false%) 108 (setf cfromc cfrom1)) 109 ((> (abs cto1) (abs cfromc)) 110 (setf mul bignum) 111 (setf done f2cl-lib:%false%) 112 (setf ctoc cto1)) 113 (t 114 (setf mul (/ ctoc cfromc)) 115 (setf done f2cl-lib:%true%))) 116 (cond 117 ((= itype 0) 118 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 119 ((> j n) nil) 120 (tagbody 121 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 122 ((> i m) nil) 123 (tagbody 124 (setf (f2cl-lib:fref a-%data% 125 (i j) 126 ((1 lda) (1 *)) 127 a-%offset%) 128 (* 129 (f2cl-lib:fref a-%data% 130 (i j) 131 ((1 lda) (1 *)) 132 a-%offset%) 133 mul)) 134 label20)) 135 label30))) 136 ((= itype 1) 137 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 138 ((> j n) nil) 139 (tagbody 140 (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1)) 141 ((> i m) nil) 142 (tagbody 143 (setf (f2cl-lib:fref a-%data% 144 (i j) 145 ((1 lda) (1 *)) 146 a-%offset%) 147 (* 148 (f2cl-lib:fref a-%data% 149 (i j) 150 ((1 lda) (1 *)) 151 a-%offset%) 152 mul)) 153 label40)) 154 label50))) 155 ((= itype 2) 156 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 157 ((> j n) nil) 158 (tagbody 159 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 160 ((> i 161 (min (the f2cl-lib:integer4 j) 162 (the f2cl-lib:integer4 m))) 163 nil) 164 (tagbody 165 (setf (f2cl-lib:fref a-%data% 166 (i j) 167 ((1 lda) (1 *)) 168 a-%offset%) 169 (* 170 (f2cl-lib:fref a-%data% 171 (i j) 172 ((1 lda) (1 *)) 173 a-%offset%) 174 mul)) 175 label60)) 176 label70))) 177 ((= itype 3) 178 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 179 ((> j n) nil) 180 (tagbody 181 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 182 ((> i 183 (min 184 (the f2cl-lib:integer4 185 (f2cl-lib:int-add j 1)) 186 (the f2cl-lib:integer4 m))) 187 nil) 188 (tagbody 189 (setf (f2cl-lib:fref a-%data% 190 (i j) 191 ((1 lda) (1 *)) 192 a-%offset%) 193 (* 194 (f2cl-lib:fref a-%data% 195 (i j) 196 ((1 lda) (1 *)) 197 a-%offset%) 198 mul)) 199 label80)) 200 label90))) 201 ((= itype 4) 202 (setf k3 (f2cl-lib:int-add kl 1)) 203 (setf k4 (f2cl-lib:int-add n 1)) 204 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 205 ((> j n) nil) 206 (tagbody 207 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 208 ((> i 209 (min (the f2cl-lib:integer4 k3) 210 (the f2cl-lib:integer4 211 (f2cl-lib:int-add k4 212 (f2cl-lib:int-sub 213 j))))) 214 nil) 215 (tagbody 216 (setf (f2cl-lib:fref a-%data% 217 (i j) 218 ((1 lda) (1 *)) 219 a-%offset%) 220 (* 221 (f2cl-lib:fref a-%data% 222 (i j) 223 ((1 lda) (1 *)) 224 a-%offset%) 225 mul)) 226 label100)) 227 label110))) 228 ((= itype 5) 229 (setf k1 (f2cl-lib:int-add ku 2)) 230 (setf k3 (f2cl-lib:int-add ku 1)) 231 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 232 ((> j n) nil) 233 (tagbody 234 (f2cl-lib:fdo (i 235 (max 236 (the f2cl-lib:integer4 237 (f2cl-lib:int-add k1 (f2cl-lib:int-sub j))) 238 (the f2cl-lib:integer4 1)) 239 (f2cl-lib:int-add i 1)) 240 ((> i k3) nil) 241 (tagbody 242 (setf (f2cl-lib:fref a-%data% 243 (i j) 244 ((1 lda) (1 *)) 245 a-%offset%) 246 (* 247 (f2cl-lib:fref a-%data% 248 (i j) 249 ((1 lda) (1 *)) 250 a-%offset%) 251 mul)) 252 label120)) 253 label130))) 254 ((= itype 6) 255 (setf k1 (f2cl-lib:int-add kl ku 2)) 256 (setf k2 (f2cl-lib:int-add kl 1)) 257 (setf k3 (f2cl-lib:int-add (f2cl-lib:int-mul 2 kl) ku 1)) 258 (setf k4 (f2cl-lib:int-add kl ku 1 m)) 259 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 260 ((> j n) nil) 261 (tagbody 262 (f2cl-lib:fdo (i 263 (max 264 (the f2cl-lib:integer4 265 (f2cl-lib:int-add k1 (f2cl-lib:int-sub j))) 266 (the f2cl-lib:integer4 k2)) 267 (f2cl-lib:int-add i 1)) 268 ((> i 269 (min (the f2cl-lib:integer4 k3) 270 (the f2cl-lib:integer4 271 (f2cl-lib:int-add k4 272 (f2cl-lib:int-sub 273 j))))) 274 nil) 275 (tagbody 276 (setf (f2cl-lib:fref a-%data% 277 (i j) 278 ((1 lda) (1 *)) 279 a-%offset%) 280 (* 281 (f2cl-lib:fref a-%data% 282 (i j) 283 ((1 lda) (1 *)) 284 a-%offset%) 285 mul)) 286 label140)) 287 label150)))) 288 (if (not done) (go label10)) 289 (go end_label) 290 end_label 291 (return (values nil nil nil nil nil nil nil nil nil info)))))) 292 293(in-package #-gcl #:cl-user #+gcl "CL-USER") 294#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 295(eval-when (:load-toplevel :compile-toplevel :execute) 296 (setf (gethash 'fortran-to-lisp::dlascl 297 fortran-to-lisp::*f2cl-function-info*) 298 (fortran-to-lisp::make-f2cl-finfo 299 :arg-types '((simple-string) (fortran-to-lisp::integer4) 300 (fortran-to-lisp::integer4) (double-float) 301 (double-float) (fortran-to-lisp::integer4) 302 (fortran-to-lisp::integer4) (array double-float (*)) 303 (fortran-to-lisp::integer4) 304 (fortran-to-lisp::integer4)) 305 :return-values '(nil nil nil nil nil nil nil nil nil 306 fortran-to-lisp::info) 307 :calls '(fortran-to-lisp::dlamch fortran-to-lisp::xerbla 308 fortran-to-lisp::lsame)))) 309 310