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(defun ilaenv (ispec name opts n1 n2 n3 n4) 21 (declare (type (simple-string *) opts name) 22 (type (f2cl-lib:integer4) n4 n3 n2 n1 ispec)) 23 (f2cl-lib:with-multi-array-data 24 ((name character name-%data% name-%offset%) 25 (opts character opts-%data% opts-%offset%)) 26 (prog ((i 0) (ic 0) (iz 0) (nb 0) (nbmin 0) (nx 0) 27 (subnam 28 (make-array '(6) :element-type 'character :initial-element #\ )) 29 (c3 (make-array '(3) :element-type 'character :initial-element #\ )) 30 (c2 (make-array '(2) :element-type 'character :initial-element #\ )) 31 (c4 (make-array '(2) :element-type 'character :initial-element #\ )) 32 (c1 (make-array '(1) :element-type 'character :initial-element #\ )) 33 (cname nil) (sname nil) (ilaenv 0)) 34 (declare (type f2cl-lib:logical sname cname) 35 (type (simple-string 1) c1) 36 (type (simple-string 2) c4 c2) 37 (type (simple-string 3) c3) 38 (type (simple-string 6) subnam) 39 (type (f2cl-lib:integer4) ilaenv nx nbmin nb iz ic i)) 40 (f2cl-lib:computed-goto 41 (label100 label100 label100 label400 label500 label600 label700 label800 42 label900 label1000 label1100) 43 ispec) 44 (setf ilaenv -1) 45 (go end_label) 46 label100 47 (setf ilaenv 1) 48 (f2cl-lib:f2cl-set-string subnam name (string 6)) 49 (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (1 1)))) 50 (setf iz (f2cl-lib:ichar "Z")) 51 (cond 52 ((or (= iz 90) (= iz 122)) 53 (cond 54 ((and (>= ic 97) (<= ic 122)) 55 (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1)) 56 (f2cl-lib:fchar (f2cl-lib:int-sub ic 32))) 57 (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) 58 ((> i 6) nil) 59 (tagbody 60 (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i)))) 61 (if (and (>= ic 97) (<= ic 122)) 62 (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i)) 63 (f2cl-lib:fchar 64 (f2cl-lib:int-sub ic 32)))) 65 label10))))) 66 ((or (= iz 233) (= iz 169)) 67 (cond 68 ((or (and (>= ic 129) (<= ic 137)) 69 (and (>= ic 145) (<= ic 153)) 70 (and (>= ic 162) (<= ic 169))) 71 (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1)) 72 (f2cl-lib:fchar (f2cl-lib:int-add ic 64))) 73 (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) 74 ((> i 6) nil) 75 (tagbody 76 (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i)))) 77 (if 78 (or (and (>= ic 129) (<= ic 137)) 79 (and (>= ic 145) (<= ic 153)) 80 (and (>= ic 162) (<= ic 169))) 81 (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i)) 82 (f2cl-lib:fchar 83 (f2cl-lib:int-add ic 64)))) 84 label20))))) 85 ((or (= iz 218) (= iz 250)) 86 (cond 87 ((and (>= ic 225) (<= ic 250)) 88 (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (1 1)) 89 (f2cl-lib:fchar (f2cl-lib:int-sub ic 32))) 90 (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1)) 91 ((> i 6) nil) 92 (tagbody 93 (setf ic (f2cl-lib:ichar (f2cl-lib:fref-string subnam (i i)))) 94 (if (and (>= ic 225) (<= ic 250)) 95 (f2cl-lib:fset-string (f2cl-lib:fref-string subnam (i i)) 96 (f2cl-lib:fchar 97 (f2cl-lib:int-sub ic 32)))) 98 label30)))))) 99 (f2cl-lib:f2cl-set-string c1 100 (f2cl-lib:fref-string subnam (1 1)) 101 (string 1)) 102 (setf sname (or (f2cl-lib:fstring-= c1 "S") (f2cl-lib:fstring-= c1 "D"))) 103 (setf cname (or (f2cl-lib:fstring-= c1 "C") (f2cl-lib:fstring-= c1 "Z"))) 104 (if (not (or cname sname)) (go end_label)) 105 (f2cl-lib:f2cl-set-string c2 106 (f2cl-lib:fref-string subnam (2 3)) 107 (string 2)) 108 (f2cl-lib:f2cl-set-string c3 109 (f2cl-lib:fref-string subnam (4 6)) 110 (string 3)) 111 (f2cl-lib:f2cl-set-string c4 (f2cl-lib:fref-string c3 (2 3)) (string 2)) 112 (f2cl-lib:computed-goto (label110 label200 label300) ispec) 113 label110 114 (setf nb 1) 115 (cond 116 ((f2cl-lib:fstring-= c2 "GE") 117 (cond 118 ((f2cl-lib:fstring-= c3 "TRF") 119 (cond 120 (sname 121 (setf nb 64)) 122 (t 123 (setf nb 64)))) 124 ((or (f2cl-lib:fstring-= c3 "QRF") 125 (f2cl-lib:fstring-= c3 "RQF") 126 (f2cl-lib:fstring-= c3 "LQF") 127 (f2cl-lib:fstring-= c3 "QLF")) 128 (cond 129 (sname 130 (setf nb 32)) 131 (t 132 (setf nb 32)))) 133 ((f2cl-lib:fstring-= c3 "HRD") 134 (cond 135 (sname 136 (setf nb 32)) 137 (t 138 (setf nb 32)))) 139 ((f2cl-lib:fstring-= c3 "BRD") 140 (cond 141 (sname 142 (setf nb 32)) 143 (t 144 (setf nb 32)))) 145 ((f2cl-lib:fstring-= c3 "TRI") 146 (cond 147 (sname 148 (setf nb 64)) 149 (t 150 (setf nb 64)))))) 151 ((f2cl-lib:fstring-= c2 "PO") 152 (cond 153 ((f2cl-lib:fstring-= c3 "TRF") 154 (cond 155 (sname 156 (setf nb 64)) 157 (t 158 (setf nb 64)))))) 159 ((f2cl-lib:fstring-= c2 "SY") 160 (cond 161 ((f2cl-lib:fstring-= c3 "TRF") 162 (cond 163 (sname 164 (setf nb 64)) 165 (t 166 (setf nb 64)))) 167 ((and sname (f2cl-lib:fstring-= c3 "TRD")) 168 (setf nb 32)) 169 ((and sname (f2cl-lib:fstring-= c3 "GST")) 170 (setf nb 64)))) 171 ((and cname (f2cl-lib:fstring-= c2 "HE")) 172 (cond 173 ((f2cl-lib:fstring-= c3 "TRF") 174 (setf nb 64)) 175 ((f2cl-lib:fstring-= c3 "TRD") 176 (setf nb 32)) 177 ((f2cl-lib:fstring-= c3 "GST") 178 (setf nb 64)))) 179 ((and sname (f2cl-lib:fstring-= c2 "OR")) 180 (cond 181 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") 182 (cond 183 ((or (f2cl-lib:fstring-= c4 "QR") 184 (f2cl-lib:fstring-= c4 "RQ") 185 (f2cl-lib:fstring-= c4 "LQ") 186 (f2cl-lib:fstring-= c4 "QL") 187 (f2cl-lib:fstring-= c4 "HR") 188 (f2cl-lib:fstring-= c4 "TR") 189 (f2cl-lib:fstring-= c4 "BR")) 190 (setf nb 32)))) 191 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M") 192 (cond 193 ((or (f2cl-lib:fstring-= c4 "QR") 194 (f2cl-lib:fstring-= c4 "RQ") 195 (f2cl-lib:fstring-= c4 "LQ") 196 (f2cl-lib:fstring-= c4 "QL") 197 (f2cl-lib:fstring-= c4 "HR") 198 (f2cl-lib:fstring-= c4 "TR") 199 (f2cl-lib:fstring-= c4 "BR")) 200 (setf nb 32)))))) 201 ((and cname (f2cl-lib:fstring-= c2 "UN")) 202 (cond 203 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") 204 (cond 205 ((or (f2cl-lib:fstring-= c4 "QR") 206 (f2cl-lib:fstring-= c4 "RQ") 207 (f2cl-lib:fstring-= c4 "LQ") 208 (f2cl-lib:fstring-= c4 "QL") 209 (f2cl-lib:fstring-= c4 "HR") 210 (f2cl-lib:fstring-= c4 "TR") 211 (f2cl-lib:fstring-= c4 "BR")) 212 (setf nb 32)))) 213 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M") 214 (cond 215 ((or (f2cl-lib:fstring-= c4 "QR") 216 (f2cl-lib:fstring-= c4 "RQ") 217 (f2cl-lib:fstring-= c4 "LQ") 218 (f2cl-lib:fstring-= c4 "QL") 219 (f2cl-lib:fstring-= c4 "HR") 220 (f2cl-lib:fstring-= c4 "TR") 221 (f2cl-lib:fstring-= c4 "BR")) 222 (setf nb 32)))))) 223 ((f2cl-lib:fstring-= c2 "GB") 224 (cond 225 ((f2cl-lib:fstring-= c3 "TRF") 226 (cond 227 (sname 228 (cond 229 ((<= n4 64) 230 (setf nb 1)) 231 (t 232 (setf nb 32)))) 233 (t 234 (cond 235 ((<= n4 64) 236 (setf nb 1)) 237 (t 238 (setf nb 32)))))))) 239 ((f2cl-lib:fstring-= c2 "PB") 240 (cond 241 ((f2cl-lib:fstring-= c3 "TRF") 242 (cond 243 (sname 244 (cond 245 ((<= n2 64) 246 (setf nb 1)) 247 (t 248 (setf nb 32)))) 249 (t 250 (cond 251 ((<= n2 64) 252 (setf nb 1)) 253 (t 254 (setf nb 32)))))))) 255 ((f2cl-lib:fstring-= c2 "TR") 256 (cond 257 ((f2cl-lib:fstring-= c3 "TRI") 258 (cond 259 (sname 260 (setf nb 64)) 261 (t 262 (setf nb 64)))))) 263 ((f2cl-lib:fstring-= c2 "LA") 264 (cond 265 ((f2cl-lib:fstring-= c3 "UUM") 266 (cond 267 (sname 268 (setf nb 64)) 269 (t 270 (setf nb 64)))))) 271 ((and sname (f2cl-lib:fstring-= c2 "ST")) 272 (cond 273 ((f2cl-lib:fstring-= c3 "EBZ") 274 (setf nb 1))))) 275 (setf ilaenv nb) 276 (go end_label) 277 label200 278 (setf nbmin 2) 279 (cond 280 ((f2cl-lib:fstring-= c2 "GE") 281 (cond 282 ((or (f2cl-lib:fstring-= c3 "QRF") 283 (f2cl-lib:fstring-= c3 "RQF") 284 (f2cl-lib:fstring-= c3 "LQF") 285 (f2cl-lib:fstring-= c3 "QLF")) 286 (cond 287 (sname 288 (setf nbmin 2)) 289 (t 290 (setf nbmin 2)))) 291 ((f2cl-lib:fstring-= c3 "HRD") 292 (cond 293 (sname 294 (setf nbmin 2)) 295 (t 296 (setf nbmin 2)))) 297 ((f2cl-lib:fstring-= c3 "BRD") 298 (cond 299 (sname 300 (setf nbmin 2)) 301 (t 302 (setf nbmin 2)))) 303 ((f2cl-lib:fstring-= c3 "TRI") 304 (cond 305 (sname 306 (setf nbmin 2)) 307 (t 308 (setf nbmin 2)))))) 309 ((f2cl-lib:fstring-= c2 "SY") 310 (cond 311 ((f2cl-lib:fstring-= c3 "TRF") 312 (cond 313 (sname 314 (setf nbmin 8)) 315 (t 316 (setf nbmin 8)))) 317 ((and sname (f2cl-lib:fstring-= c3 "TRD")) 318 (setf nbmin 2)))) 319 ((and cname (f2cl-lib:fstring-= c2 "HE")) 320 (cond 321 ((f2cl-lib:fstring-= c3 "TRD") 322 (setf nbmin 2)))) 323 ((and sname (f2cl-lib:fstring-= c2 "OR")) 324 (cond 325 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") 326 (cond 327 ((or (f2cl-lib:fstring-= c4 "QR") 328 (f2cl-lib:fstring-= c4 "RQ") 329 (f2cl-lib:fstring-= c4 "LQ") 330 (f2cl-lib:fstring-= c4 "QL") 331 (f2cl-lib:fstring-= c4 "HR") 332 (f2cl-lib:fstring-= c4 "TR") 333 (f2cl-lib:fstring-= c4 "BR")) 334 (setf nbmin 2)))) 335 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M") 336 (cond 337 ((or (f2cl-lib:fstring-= c4 "QR") 338 (f2cl-lib:fstring-= c4 "RQ") 339 (f2cl-lib:fstring-= c4 "LQ") 340 (f2cl-lib:fstring-= c4 "QL") 341 (f2cl-lib:fstring-= c4 "HR") 342 (f2cl-lib:fstring-= c4 "TR") 343 (f2cl-lib:fstring-= c4 "BR")) 344 (setf nbmin 2)))))) 345 ((and cname (f2cl-lib:fstring-= c2 "UN")) 346 (cond 347 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") 348 (cond 349 ((or (f2cl-lib:fstring-= c4 "QR") 350 (f2cl-lib:fstring-= c4 "RQ") 351 (f2cl-lib:fstring-= c4 "LQ") 352 (f2cl-lib:fstring-= c4 "QL") 353 (f2cl-lib:fstring-= c4 "HR") 354 (f2cl-lib:fstring-= c4 "TR") 355 (f2cl-lib:fstring-= c4 "BR")) 356 (setf nbmin 2)))) 357 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "M") 358 (cond 359 ((or (f2cl-lib:fstring-= c4 "QR") 360 (f2cl-lib:fstring-= c4 "RQ") 361 (f2cl-lib:fstring-= c4 "LQ") 362 (f2cl-lib:fstring-= c4 "QL") 363 (f2cl-lib:fstring-= c4 "HR") 364 (f2cl-lib:fstring-= c4 "TR") 365 (f2cl-lib:fstring-= c4 "BR")) 366 (setf nbmin 2))))))) 367 (setf ilaenv nbmin) 368 (go end_label) 369 label300 370 (setf nx 0) 371 (cond 372 ((f2cl-lib:fstring-= c2 "GE") 373 (cond 374 ((or (f2cl-lib:fstring-= c3 "QRF") 375 (f2cl-lib:fstring-= c3 "RQF") 376 (f2cl-lib:fstring-= c3 "LQF") 377 (f2cl-lib:fstring-= c3 "QLF")) 378 (cond 379 (sname 380 (setf nx 128)) 381 (t 382 (setf nx 128)))) 383 ((f2cl-lib:fstring-= c3 "HRD") 384 (cond 385 (sname 386 (setf nx 128)) 387 (t 388 (setf nx 128)))) 389 ((f2cl-lib:fstring-= c3 "BRD") 390 (cond 391 (sname 392 (setf nx 128)) 393 (t 394 (setf nx 128)))))) 395 ((f2cl-lib:fstring-= c2 "SY") 396 (cond 397 ((and sname (f2cl-lib:fstring-= c3 "TRD")) 398 (setf nx 32)))) 399 ((and cname (f2cl-lib:fstring-= c2 "HE")) 400 (cond 401 ((f2cl-lib:fstring-= c3 "TRD") 402 (setf nx 32)))) 403 ((and sname (f2cl-lib:fstring-= c2 "OR")) 404 (cond 405 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") 406 (cond 407 ((or (f2cl-lib:fstring-= c4 "QR") 408 (f2cl-lib:fstring-= c4 "RQ") 409 (f2cl-lib:fstring-= c4 "LQ") 410 (f2cl-lib:fstring-= c4 "QL") 411 (f2cl-lib:fstring-= c4 "HR") 412 (f2cl-lib:fstring-= c4 "TR") 413 (f2cl-lib:fstring-= c4 "BR")) 414 (setf nx 128)))))) 415 ((and cname (f2cl-lib:fstring-= c2 "UN")) 416 (cond 417 ((f2cl-lib:fstring-= (f2cl-lib:fref-string c3 (1 1)) "G") 418 (cond 419 ((or (f2cl-lib:fstring-= c4 "QR") 420 (f2cl-lib:fstring-= c4 "RQ") 421 (f2cl-lib:fstring-= c4 "LQ") 422 (f2cl-lib:fstring-= c4 "QL") 423 (f2cl-lib:fstring-= c4 "HR") 424 (f2cl-lib:fstring-= c4 "TR") 425 (f2cl-lib:fstring-= c4 "BR")) 426 (setf nx 128))))))) 427 (setf ilaenv nx) 428 (go end_label) 429 label400 430 (setf ilaenv 6) 431 (go end_label) 432 label500 433 (setf ilaenv 2) 434 (go end_label) 435 label600 436 (setf ilaenv 437 (f2cl-lib:int 438 (* 439 (f2cl-lib:freal 440 (min (the f2cl-lib:integer4 n1) (the f2cl-lib:integer4 n2))) 441 1.6f0))) 442 (go end_label) 443 label700 444 (setf ilaenv 1) 445 (go end_label) 446 label800 447 (setf ilaenv 50) 448 (go end_label) 449 label900 450 (setf ilaenv 25) 451 (go end_label) 452 label1000 453 (setf ilaenv 0) 454 (cond 455 ((= ilaenv 1) 456 (setf ilaenv (ieeeck 0 0.0f0 1.0f0)))) 457 (go end_label) 458 label1100 459 (setf ilaenv 0) 460 (cond 461 ((= ilaenv 1) 462 (setf ilaenv (ieeeck 1 0.0f0 1.0f0)))) 463 (go end_label) 464 end_label 465 (return (values ilaenv nil nil nil nil nil nil nil))))) 466 467(in-package #-gcl #:cl-user #+gcl "CL-USER") 468#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 469(eval-when (:load-toplevel :compile-toplevel :execute) 470 (setf (gethash 'fortran-to-lisp::ilaenv 471 fortran-to-lisp::*f2cl-function-info*) 472 (fortran-to-lisp::make-f2cl-finfo 473 :arg-types '((fortran-to-lisp::integer4) (simple-string) 474 (simple-string) (fortran-to-lisp::integer4) 475 (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) 476 (fortran-to-lisp::integer4)) 477 :return-values '(nil nil nil nil nil nil nil) 478 :calls '(fortran-to-lisp::ieeeck)))) 479 480