;;; Compiled by f2cl version 2.0 beta Date: 2006/12/21 03:42:11 ;;; Using Lisp CMU Common Lisp CVS Head 2006-12-02 00:15:46 (19D) ;;; ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t) ;;; (:coerce-assigns :as-needed) (:array-type ':array) ;;; (:array-slicing t) (:declare-common nil) ;;; (:float-format double-float)) (in-package :blas) (let* ((zero 0.0)) (declare (type (double-float 0.0 0.0) zero)) (defun dtbsv (uplo trans diag n k a lda x incx) (declare (type (array double-float (*)) x a) (type (f2cl-lib:integer4) incx lda k n) (type (simple-array character (*)) diag trans uplo)) (f2cl-lib:with-multi-array-data ((uplo character uplo-%data% uplo-%offset%) (trans character trans-%data% trans-%offset%) (diag character diag-%data% diag-%offset%) (a double-float a-%data% a-%offset%) (x double-float x-%data% x-%offset%)) (prog ((nounit nil) (i 0) (info 0) (ix 0) (j 0) (jx 0) (kplus1 0) (kx 0) (l 0) (temp 0.0)) (declare (type f2cl-lib:logical nounit) (type (f2cl-lib:integer4) i info ix j jx kplus1 kx l) (type (double-float) temp)) (setf info 0) (cond ((and (not (lsame uplo "U")) (not (lsame uplo "L"))) (setf info 1)) ((and (not (lsame trans "N")) (not (lsame trans "T")) (not (lsame trans "C"))) (setf info 2)) ((and (not (lsame diag "U")) (not (lsame diag "N"))) (setf info 3)) ((< n 0) (setf info 4)) ((< k 0) (setf info 5)) ((< lda (f2cl-lib:int-add k 1)) (setf info 7)) ((= incx 0) (setf info 9))) (cond ((/= info 0) (xerbla "DTBSV " info) (go end_label))) (if (= n 0) (go end_label)) (setf nounit (lsame diag "N")) (cond ((<= incx 0) (setf kx (f2cl-lib:int-sub 1 (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) incx)))) ((/= incx 1) (setf kx 1))) (cond ((lsame trans "N") (cond ((lsame uplo "U") (setf kplus1 (f2cl-lib:int-add k 1)) (cond ((= incx 1) (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) ((> j 1) nil) (tagbody (cond ((/= (f2cl-lib:fref x (j) ((1 *))) zero) (setf l (f2cl-lib:int-sub kplus1 j)) (if nounit (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) (/ (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) (f2cl-lib:fref a-%data% (kplus1 j) ((1 lda) (1 *)) a-%offset%)))) (setf temp (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) ((> i (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 (f2cl-lib:int-add j (f2cl-lib:int-sub k))))) nil) (tagbody (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) (- (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) (* temp (f2cl-lib:fref a-%data% ((f2cl-lib:int-add l i) j) ((1 lda) (1 *)) a-%offset%)))) label10)))) label20))) (t (setf kx (f2cl-lib:int-add kx (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) incx))) (setf jx kx) (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) ((> j 1) nil) (tagbody (setf kx (f2cl-lib:int-sub kx incx)) (cond ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) (setf ix kx) (setf l (f2cl-lib:int-sub kplus1 j)) (if nounit (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) (/ (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) (f2cl-lib:fref a-%data% (kplus1 j) ((1 lda) (1 *)) a-%offset%)))) (setf temp (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) (f2cl-lib:fdo (i (f2cl-lib:int-add j (f2cl-lib:int-sub 1)) (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) ((> i (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 (f2cl-lib:int-add j (f2cl-lib:int-sub k))))) nil) (tagbody (setf (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%) (- (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%) (* temp (f2cl-lib:fref a-%data% ((f2cl-lib:int-add l i) j) ((1 lda) (1 *)) a-%offset%)))) (setf ix (f2cl-lib:int-sub ix incx)) label30)))) (setf jx (f2cl-lib:int-sub jx incx)) label40))))) (t (cond ((= incx 1) (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) ((> j n) nil) (tagbody (cond ((/= (f2cl-lib:fref x (j) ((1 *))) zero) (setf l (f2cl-lib:int-sub 1 j)) (if nounit (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) (/ (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) (f2cl-lib:fref a-%data% (1 j) ((1 lda) (1 *)) a-%offset%)))) (setf temp (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) (f2cl-lib:int-add i 1)) ((> i (min (the f2cl-lib:integer4 n) (the f2cl-lib:integer4 (f2cl-lib:int-add j k)))) nil) (tagbody (setf (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) (- (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%) (* temp (f2cl-lib:fref a-%data% ((f2cl-lib:int-add l i) j) ((1 lda) (1 *)) a-%offset%)))) label50)))) label60))) (t (setf jx kx) (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) ((> j n) nil) (tagbody (setf kx (f2cl-lib:int-add kx incx)) (cond ((/= (f2cl-lib:fref x (jx) ((1 *))) zero) (setf ix kx) (setf l (f2cl-lib:int-sub 1 j)) (if nounit (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) (/ (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) (f2cl-lib:fref a-%data% (1 j) ((1 lda) (1 *)) a-%offset%)))) (setf temp (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) (f2cl-lib:fdo (i (f2cl-lib:int-add j 1) (f2cl-lib:int-add i 1)) ((> i (min (the f2cl-lib:integer4 n) (the f2cl-lib:integer4 (f2cl-lib:int-add j k)))) nil) (tagbody (setf (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%) (- (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%) (* temp (f2cl-lib:fref a-%data% ((f2cl-lib:int-add l i) j) ((1 lda) (1 *)) a-%offset%)))) (setf ix (f2cl-lib:int-add ix incx)) label70)))) (setf jx (f2cl-lib:int-add jx incx)) label80))))))) (t (cond ((lsame uplo "U") (setf kplus1 (f2cl-lib:int-add k 1)) (cond ((= incx 1) (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) ((> j n) nil) (tagbody (setf temp (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) (setf l (f2cl-lib:int-sub kplus1 j)) (f2cl-lib:fdo (i (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 (f2cl-lib:int-add j (f2cl-lib:int-sub k)))) (f2cl-lib:int-add i 1)) ((> i (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) nil) (tagbody (setf temp (- temp (* (f2cl-lib:fref a-%data% ((f2cl-lib:int-add l i) j) ((1 lda) (1 *)) a-%offset%) (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)))) label90)) (if nounit (setf temp (/ temp (f2cl-lib:fref a-%data% (kplus1 j) ((1 lda) (1 *)) a-%offset%)))) (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) temp) label100))) (t (setf jx kx) (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1)) ((> j n) nil) (tagbody (setf temp (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) (setf ix kx) (setf l (f2cl-lib:int-sub kplus1 j)) (f2cl-lib:fdo (i (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 (f2cl-lib:int-add j (f2cl-lib:int-sub k)))) (f2cl-lib:int-add i 1)) ((> i (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) nil) (tagbody (setf temp (- temp (* (f2cl-lib:fref a-%data% ((f2cl-lib:int-add l i) j) ((1 lda) (1 *)) a-%offset%) (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)))) (setf ix (f2cl-lib:int-add ix incx)) label110)) (if nounit (setf temp (/ temp (f2cl-lib:fref a-%data% (kplus1 j) ((1 lda) (1 *)) a-%offset%)))) (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) temp) (setf jx (f2cl-lib:int-add jx incx)) (if (> j k) (setf kx (f2cl-lib:int-add kx incx))) label120))))) (t (cond ((= incx 1) (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) ((> j 1) nil) (tagbody (setf temp (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%)) (setf l (f2cl-lib:int-sub 1 j)) (f2cl-lib:fdo (i (min (the f2cl-lib:integer4 n) (the f2cl-lib:integer4 (f2cl-lib:int-add j k))) (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) ((> i (f2cl-lib:int-add j 1)) nil) (tagbody (setf temp (- temp (* (f2cl-lib:fref a-%data% ((f2cl-lib:int-add l i) j) ((1 lda) (1 *)) a-%offset%) (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)))) label130)) (if nounit (setf temp (/ temp (f2cl-lib:fref a-%data% (1 j) ((1 lda) (1 *)) a-%offset%)))) (setf (f2cl-lib:fref x-%data% (j) ((1 *)) x-%offset%) temp) label140))) (t (setf kx (f2cl-lib:int-add kx (f2cl-lib:int-mul (f2cl-lib:int-sub n 1) incx))) (setf jx kx) (f2cl-lib:fdo (j n (f2cl-lib:int-add j (f2cl-lib:int-sub 1))) ((> j 1) nil) (tagbody (setf temp (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%)) (setf ix kx) (setf l (f2cl-lib:int-sub 1 j)) (f2cl-lib:fdo (i (min (the f2cl-lib:integer4 n) (the f2cl-lib:integer4 (f2cl-lib:int-add j k))) (f2cl-lib:int-add i (f2cl-lib:int-sub 1))) ((> i (f2cl-lib:int-add j 1)) nil) (tagbody (setf temp (- temp (* (f2cl-lib:fref a-%data% ((f2cl-lib:int-add l i) j) ((1 lda) (1 *)) a-%offset%) (f2cl-lib:fref x-%data% (ix) ((1 *)) x-%offset%)))) (setf ix (f2cl-lib:int-sub ix incx)) label150)) (if nounit (setf temp (/ temp (f2cl-lib:fref a-%data% (1 j) ((1 lda) (1 *)) a-%offset%)))) (setf (f2cl-lib:fref x-%data% (jx) ((1 *)) x-%offset%) temp) (setf jx (f2cl-lib:int-sub jx incx)) (if (>= (f2cl-lib:int-sub n j) k) (setf kx (f2cl-lib:int-sub kx incx))) label160)))))))) (go end_label) end_label (return (values nil nil nil nil nil nil nil nil nil)))))) (in-package #-gcl #:cl-user #+gcl "CL-USER") #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or)) (eval-when (:load-toplevel :compile-toplevel :execute) (setf (gethash 'fortran-to-lisp::dtbsv fortran-to-lisp::*f2cl-function-info*) (fortran-to-lisp::make-f2cl-finfo :arg-types '((simple-array character (1)) (simple-array character (1)) (simple-array character (1)) (fortran-to-lisp::integer4) (fortran-to-lisp::integer4) (array double-float (*)) (fortran-to-lisp::integer4) (array double-float (*)) (fortran-to-lisp::integer4)) :return-values '(nil nil nil nil nil nil nil nil nil) :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))))