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 :blas) 18 19 20(let* ((zero 0.0)) 21 (declare (type (double-float 0.0 0.0) zero) (ignorable zero)) 22 (defun dtrmv (uplo trans diag n a lda x incx) 23 (declare (type (array double-float (*)) x a) 24 (type (f2cl-lib:integer4) incx lda n) 25 (type (simple-string *) diag trans uplo)) 26 (f2cl-lib:with-multi-array-data 27 ((uplo character uplo-%data% uplo-%offset%) 28 (trans character trans-%data% trans-%offset%) 29 (diag character diag-%data% diag-%offset%) 30 (a double-float a-%data% a-%offset%) 31 (x double-float x-%data% x-%offset%)) 32 (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kx 0) (temp 0.0)) 33 (declare (type f2cl-lib:logical nounit) 34 (type (f2cl-lib:integer4) i info ix j jx kx) 35 (type (double-float) temp)) 36 (setf info 0) 37 (cond 38 ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) 39 (setf info 1)) 40 ((and (not (lsame trans "N")) 41 (not (lsame trans "T")) 42 (not (lsame trans "C"))) 43 (setf info 2)) 44 ((and (not (lsame diag "U")) (not (lsame diag "N"))) 45 (setf info 3)) 46 ((< n 0) 47 (setf info 4)) 48 ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))) 49 (setf info 6)) 50 ((= incx 0) 51 (setf info 8))) 52 (cond 53 ((/= info 0) 54 (xerbla "DTRMV " info) 55 (go end_label))) 56 (if (= n 0) (go end_label)) 57 (setf nounit (lsame diag "N")) 58 (cond 59 ((<= incx 0) 60 (setf kx 61 (f2cl-lib:int-sub 1 62 (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) 63 incx)))) 64 ((/= incx 1) 65 (setf kx 1))) 66 (cond 67 ((lsame trans "N") 68 (cond 69 ((lsame uplo "U") 70 (cond 71 ((= incx 1) 72 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 73 ((> j n) nil) 74 (tagbody 75 (cond 76 ((/= (f2cl-lib:fref x (j) ((1 *))) zero) 77 (setf temp 78 (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) 79 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 80 ((> i 81 (f2cl-lib:int-add j 82 (f2cl-lib:int-sub 83 1))) 84 nil) 85 (tagbody 86 (setf (f2cl-lib:fref x-%data% 87 (i) 88 ((1 *)) 89 x-%offset%) 90 (+ 91 (f2cl-lib:fref x-%data% 92 (i) 93 ((1 *)) 94 x-%offset%) 95 (* temp 96 (f2cl-lib:fref a-%data% 97 (i j) 98 ((1 lda) (1 *)) 99 a-%offset%)))) 100 label10)) 101 (if nounit 102 (setf (f2cl-lib:fref x-%data% 103 (j) 104 ((1 *)) 105 x-%offset%) 106 (* 107 (f2cl-lib:fref x-%data% 108 (j) 109 ((1 *)) 110 x-%offset%) 111 (f2cl-lib:fref a-%data% 112 (j j) 113 ((1 lda) (1 *)) 114 a-%offset%)))))) 115 label20))) 116 (t 117 (setf jx kx) 118 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 119 ((> j n) nil) 120 (tagbody 121 (cond 122 ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) 123 (setf temp 124 (f2cl-lib:fref x-%data% 125 (jx) 126 ((1 *)) 127 x-%offset%)) 128 (setf ix kx) 129 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1)) 130 ((> i 131 (f2cl-lib:int-add j 132 (f2cl-lib:int-sub 133 1))) 134 nil) 135 (tagbody 136 (setf (f2cl-lib:fref x-%data% 137 (ix) 138 ((1 *)) 139 x-%offset%) 140 (+ 141 (f2cl-lib:fref x-%data% 142 (ix) 143 ((1 *)) 144 x-%offset%) 145 (* temp 146 (f2cl-lib:fref a-%data% 147 (i j) 148 ((1 lda) (1 *)) 149 a-%offset%)))) 150 (setf ix (f2cl-lib:int-add ix incx)) 151 label30)) 152 (if nounit 153 (setf (f2cl-lib:fref x-%data% 154 (jx) 155 ((1 *)) 156 x-%offset%) 157 (* 158 (f2cl-lib:fref x-%data% 159 (jx) 160 ((1 *)) 161 x-%offset%) 162 (f2cl-lib:fref a-%data% 163 (j j) 164 ((1 lda) (1 *)) 165 a-%offset%)))))) 166 (setf jx (f2cl-lib:int-add jx incx)) 167 label40))))) 168 (t 169 (cond 170 ((= incx 1) 171 (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) 172 ((> j 1) nil) 173 (tagbody 174 (cond 175 ((/= (f2cl-lib:fref x (j) ((1 *))) zero) 176 (setf temp 177 (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) 178 (f2cl-lib:fdo (i n 179 (f2cl-lib:int-add i 180 (f2cl-lib:int-sub 1))) 181 ((> i (f2cl-lib:int-add j 1)) nil) 182 (tagbody 183 (setf (f2cl-lib:fref x-%data% 184 (i) 185 ((1 *)) 186 x-%offset%) 187 (+ 188 (f2cl-lib:fref x-%data% 189 (i) 190 ((1 *)) 191 x-%offset%) 192 (* temp 193 (f2cl-lib:fref a-%data% 194 (i j) 195 ((1 lda) (1 *)) 196 a-%offset%)))) 197 label50)) 198 (if nounit 199 (setf (f2cl-lib:fref x-%data% 200 (j) 201 ((1 *)) 202 x-%offset%) 203 (* 204 (f2cl-lib:fref x-%data% 205 (j) 206 ((1 *)) 207 x-%offset%) 208 (f2cl-lib:fref a-%data% 209 (j j) 210 ((1 lda) (1 *)) 211 a-%offset%)))))) 212 label60))) 213 (t 214 (setf kx 215 (f2cl-lib:int-add kx 216 (f2cl-lib:int-mul 217 (f2cl-lib:int-sub n 1) 218 incx))) 219 (setf jx kx) 220 (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) 221 ((> j 1) nil) 222 (tagbody 223 (cond 224 ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) 225 (setf temp 226 (f2cl-lib:fref x-%data% 227 (jx) 228 ((1 *)) 229 x-%offset%)) 230 (setf ix kx) 231 (f2cl-lib:fdo (i n 232 (f2cl-lib:int-add i 233 (f2cl-lib:int-sub 1))) 234 ((> i (f2cl-lib:int-add j 1)) nil) 235 (tagbody 236 (setf (f2cl-lib:fref x-%data% 237 (ix) 238 ((1 *)) 239 x-%offset%) 240 (+ 241 (f2cl-lib:fref x-%data% 242 (ix) 243 ((1 *)) 244 x-%offset%) 245 (* temp 246 (f2cl-lib:fref a-%data% 247 (i j) 248 ((1 lda) (1 *)) 249 a-%offset%)))) 250 (setf ix (f2cl-lib:int-sub ix incx)) 251 label70)) 252 (if nounit 253 (setf (f2cl-lib:fref x-%data% 254 (jx) 255 ((1 *)) 256 x-%offset%) 257 (* 258 (f2cl-lib:fref x-%data% 259 (jx) 260 ((1 *)) 261 x-%offset%) 262 (f2cl-lib:fref a-%data% 263 (j j) 264 ((1 lda) (1 *)) 265 a-%offset%)))))) 266 (setf jx (f2cl-lib:int-sub jx incx)) 267 label80))))))) 268 (t 269 (cond 270 ((lsame uplo "U") 271 (cond 272 ((= incx 1) 273 (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) 274 ((> j 1) nil) 275 (tagbody 276 (setf temp 277 (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) 278 (if nounit 279 (setf temp 280 (* temp 281 (f2cl-lib:fref a-%data% 282 (j j) 283 ((1 lda) (1 *)) 284 a-%offset%)))) 285 (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) 286 (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) 287 ((> i 1) nil) 288 (tagbody 289 (setf temp 290 (+ temp 291 (* 292 (f2cl-lib:fref a-%data% 293 (i j) 294 ((1 lda) (1 *)) 295 a-%offset%) 296 (f2cl-lib:fref x-%data% 297 (i) 298 ((1 *)) 299 x-%offset%)))) 300 label90)) 301 (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) 302 temp) 303 label100))) 304 (t 305 (setf jx 306 (f2cl-lib:int-add kx 307 (f2cl-lib:int-mul 308 (f2cl-lib:int-sub n 1) 309 incx))) 310 (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) 311 ((> j 1) nil) 312 (tagbody 313 (setf temp 314 (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) 315 (setf ix jx) 316 (if nounit 317 (setf temp 318 (* temp 319 (f2cl-lib:fref a-%data% 320 (j j) 321 ((1 lda) (1 *)) 322 a-%offset%)))) 323 (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) 324 (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) 325 ((> i 1) nil) 326 (tagbody 327 (setf ix (f2cl-lib:int-sub ix incx)) 328 (setf temp 329 (+ temp 330 (* 331 (f2cl-lib:fref a-%data% 332 (i j) 333 ((1 lda) (1 *)) 334 a-%offset%) 335 (f2cl-lib:fref x-%data% 336 (ix) 337 ((1 *)) 338 x-%offset%)))) 339 label110)) 340 (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) 341 temp) 342 (setf jx (f2cl-lib:int-sub jx incx)) 343 label120))))) 344 (t 345 (cond 346 ((= incx 1) 347 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 348 ((> j n) nil) 349 (tagbody 350 (setf temp 351 (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) 352 (if nounit 353 (setf temp 354 (* temp 355 (f2cl-lib:fref a-%data% 356 (j j) 357 ((1 lda) (1 *)) 358 a-%offset%)))) 359 (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) 360 (f2cl-lib:int-add i 1)) 361 ((> i n) nil) 362 (tagbody 363 (setf temp 364 (+ temp 365 (* 366 (f2cl-lib:fref a-%data% 367 (i j) 368 ((1 lda) (1 *)) 369 a-%offset%) 370 (f2cl-lib:fref x-%data% 371 (i) 372 ((1 *)) 373 x-%offset%)))) 374 label130)) 375 (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) 376 temp) 377 label140))) 378 (t 379 (setf jx kx) 380 (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) 381 ((> j n) nil) 382 (tagbody 383 (setf temp 384 (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) 385 (setf ix jx) 386 (if nounit 387 (setf temp 388 (* temp 389 (f2cl-lib:fref a-%data% 390 (j j) 391 ((1 lda) (1 *)) 392 a-%offset%)))) 393 (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) 394 (f2cl-lib:int-add i 1)) 395 ((> i n) nil) 396 (tagbody 397 (setf ix (f2cl-lib:int-add ix incx)) 398 (setf temp 399 (+ temp 400 (* 401 (f2cl-lib:fref a-%data% 402 (i j) 403 ((1 lda) (1 *)) 404 a-%offset%) 405 (f2cl-lib:fref x-%data% 406 (ix) 407 ((1 *)) 408 x-%offset%)))) 409 label150)) 410 (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) 411 temp) 412 (setf jx (f2cl-lib:int-add jx incx)) 413 label160)))))))) 414 (go end_label) 415 end_label 416 (return (values nil nil nil nil nil nil nil nil)))))) 417 418(in-package #-gcl #:cl-user #+gcl "CL-USER") 419#+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) 420(eval-when (:load-toplevel :compile-toplevel :execute) 421 (setf (gethash 'fortran-to-lisp::dtrmv fortran-to-lisp::*f2cl-function-info*) 422 (fortran-to-lisp::make-f2cl-finfo 423 :arg-types '((simple-string) (simple-string) (simple-string) 424 (fortran-to-lisp::integer4) (array double-float (*)) 425 (fortran-to-lisp::integer4) (array double-float (*)) 426 (fortran-to-lisp::integer4)) 427 :return-values '(nil nil nil nil nil nil nil nil) 428 :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame)))) 429 430