;;; Compiled by f2cl version:
;;; ("f2cl1.l,v 2edcbd958861 2012/05/30 03:34:52 toy $"
;;;  "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
;;;  "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
;;;  "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
;;;  "f2cl5.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $"
;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
;;;  "macros.l,v 3fe93de3be82 2012/05/06 02:17:14 toy $")

;;; Using Lisp CMU Common Lisp 20d (20D Unicode)
;;; 
;;; 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 :lapack)


(let* ((nbmax 64) (ldt (+ nbmax 1)))
  (declare (type (f2cl-lib:integer4 64 64) nbmax)
           (type (f2cl-lib:integer4) ldt)
           (ignorable nbmax ldt))
  (defun dormlq (side trans m n k a lda tau c ldc work lwork info)
    (declare (type (array double-float (*)) work c tau a)
             (type (f2cl-lib:integer4) info lwork ldc lda k n m)
             (type (simple-string *) trans side))
    (f2cl-lib:with-multi-array-data
        ((side character side-%data% side-%offset%)
         (trans character trans-%data% trans-%offset%)
         (a double-float a-%data% a-%offset%)
         (tau double-float tau-%data% tau-%offset%)
         (c double-float c-%data% c-%offset%)
         (work double-float work-%data% work-%offset%))
      (prog ((i 0) (i1 0) (i2 0) (i3 0) (ib 0) (ic 0) (iinfo 0) (iws 0) (jc 0)
             (ldwork 0) (lwkopt 0) (mi 0) (nb 0) (nbmin 0) (ni 0) (nq 0) (nw 0)
             (transt
              (make-array '(1) :element-type 'character :initial-element #\ ))
             (left nil) (lquery nil) (notran nil)
             (t$
              (make-array (the fixnum (reduce #'* (list ldt nbmax)))
                          :element-type 'double-float)))
        (declare (type (array double-float (*)) t$)
                 (type (f2cl-lib:integer4) i i1 i2 i3 ib ic iinfo iws jc ldwork
                                           lwkopt mi nb nbmin ni nq nw)
                 (type (simple-string 1) transt)
                 (type f2cl-lib:logical left lquery notran))
        (setf info 0)
        (setf left (lsame side "L"))
        (setf notran (lsame trans "N"))
        (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical))
        (cond
          (left
           (setf nq m)
           (setf nw n))
          (t
           (setf nq n)
           (setf nw m)))
        (cond
          ((and (not left) (not (lsame side "R")))
           (setf info -1))
          ((and (not notran) (not (lsame trans "T")))
           (setf info -2))
          ((< m 0)
           (setf info -3))
          ((< n 0)
           (setf info -4))
          ((or (< k 0) (> k nq))
           (setf info -5))
          ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 k)))
           (setf info -7))
          ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
           (setf info -10))
          ((and
            (< lwork
               (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nw)))
            (not lquery))
           (setf info -12)))
        (cond
          ((= info 0)
           (setf nb
                   (min (the f2cl-lib:integer4 nbmax)
                        (the f2cl-lib:integer4
                             (ilaenv 1 "DORMLQ" (f2cl-lib:f2cl-// side trans) m
                              n k -1))))
           (setf lwkopt
                   (f2cl-lib:int-mul
                    (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nw))
                    nb))
           (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
                   (coerce (the f2cl-lib:integer4 lwkopt) 'double-float))))
        (cond
          ((/= info 0)
           (xerbla "DORMLQ" (f2cl-lib:int-sub info))
           (go end_label))
          (lquery
           (go end_label)))
        (cond
          ((or (= m 0) (= n 0) (= k 0))
           (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
                   (coerce (the f2cl-lib:integer4 1) 'double-float))
           (go end_label)))
        (setf nbmin 2)
        (setf ldwork nw)
        (cond
          ((and (> nb 1) (< nb k))
           (setf iws (f2cl-lib:int-mul nw nb))
           (cond
             ((< lwork iws)
              (setf nb (the f2cl-lib:integer4 (truncate lwork ldwork)))
              (setf nbmin
                      (max (the f2cl-lib:integer4 2)
                           (the f2cl-lib:integer4
                                (ilaenv 2 "DORMLQ"
                                 (f2cl-lib:f2cl-// side trans) m n k -1)))))))
          (t
           (setf iws nw)))
        (cond
          ((or (< nb nbmin) (>= nb k))
           (multiple-value-bind
                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
                  var-10 var-11)
               (dorml2 side trans m n k a lda tau c ldc work iinfo)
             (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7
                              var-8 var-9 var-10))
             (setf iinfo var-11)))
          (t
           (cond
             ((or (and left notran) (and (not left) (not notran)))
              (setf i1 1)
              (setf i2 k)
              (setf i3 nb))
             (t
              (setf i1
                      (+ (* (the f2cl-lib:integer4 (truncate (- k 1) nb)) nb)
                         1))
              (setf i2 1)
              (setf i3 (f2cl-lib:int-sub nb))))
           (cond
             (left
              (setf ni n)
              (setf jc 1))
             (t
              (setf mi m)
              (setf ic 1)))
           (cond
             (notran
              (f2cl-lib:f2cl-set-string transt "T" (string 1)))
             (t
              (f2cl-lib:f2cl-set-string transt "N" (string 1))))
           (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i i3))
                         ((> i i2) nil)
             (tagbody
               (setf ib
                       (min (the f2cl-lib:integer4 nb)
                            (the f2cl-lib:integer4
                                 (f2cl-lib:int-add (f2cl-lib:int-sub k i) 1))))
               (dlarft "Forward" "Rowwise"
                (f2cl-lib:int-add (f2cl-lib:int-sub nq i) 1) ib
                (f2cl-lib:array-slice a-%data%
                                      double-float
                                      (i i)
                                      ((1 lda) (1 *))
                                      a-%offset%)
                lda
                (f2cl-lib:array-slice tau-%data%
                                      double-float
                                      (i)
                                      ((1 *))
                                      tau-%offset%)
                t$ ldt)
               (cond
                 (left
                  (setf mi (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1))
                  (setf ic i))
                 (t
                  (setf ni (f2cl-lib:int-add (f2cl-lib:int-sub n i) 1))
                  (setf jc i)))
               (dlarfb side transt "Forward" "Rowwise" mi ni ib
                (f2cl-lib:array-slice a-%data%
                                      double-float
                                      (i i)
                                      ((1 lda) (1 *))
                                      a-%offset%)
                lda t$ ldt
                (f2cl-lib:array-slice c-%data%
                                      double-float
                                      (ic jc)
                                      ((1 ldc) (1 *))
                                      c-%offset%)
                ldc work ldwork)
              label10))))
        (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
                (coerce (the f2cl-lib:integer4 lwkopt) 'double-float))
        (go end_label)
       end_label
        (return
         (values nil nil nil nil nil nil nil nil nil nil nil nil info))))))

(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::dormlq
                 fortran-to-lisp::*f2cl-function-info*)
          (fortran-to-lisp::make-f2cl-finfo
           :arg-types '((simple-string) (simple-string)
                        (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
                        (fortran-to-lisp::integer4) (array double-float (*))
                        (fortran-to-lisp::integer4) (array double-float (*))
                        (array double-float (*)) (fortran-to-lisp::integer4)
                        (array double-float (*)) (fortran-to-lisp::integer4)
                        (fortran-to-lisp::integer4))
           :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil
                            fortran-to-lisp::info)
           :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft
                    fortran-to-lisp::dorml2 fortran-to-lisp::xerbla
                    fortran-to-lisp::ilaenv fortran-to-lisp::lsame))))

