;;; Compiled by f2cl version:
;;; ("f2cl1.l,v 1.215 2009/04/07 22:05:21 rtoy Exp $"
;;;  "f2cl2.l,v 1.37 2008/02/22 22:19:33 rtoy Exp $"
;;;  "f2cl3.l,v 1.6 2008/02/22 22:19:33 rtoy Exp $"
;;;  "f2cl4.l,v 1.7 2008/02/22 22:19:34 rtoy Exp $"
;;;  "f2cl5.l,v 1.200 2009/01/19 02:38:17 rtoy Exp $"
;;;  "f2cl6.l,v 1.48 2008/08/24 00:56:27 rtoy Exp $"
;;;  "macros.l,v 1.112 2009/01/08 12:57:19 rtoy Exp $")

;;; Using Lisp CMU Common Lisp 19f (19F)
;;; 
;;; 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* ((zero 0.0))
  (declare (type (double-float 0.0 0.0) zero) (ignorable zero))
  (defun dorgqr (m n k a lda tau work lwork info)
    (declare (type (array double-float (*)) work tau a)
             (type (f2cl-lib:integer4) info lwork lda k n m))
    (f2cl-lib:with-multi-array-data
        ((a double-float a-%data% a-%offset%)
         (tau double-float tau-%data% tau-%offset%)
         (work double-float work-%data% work-%offset%))
      (prog ((i 0) (ib 0) (iinfo 0) (iws 0) (j 0) (ki 0) (kk 0) (l 0)
             (ldwork 0) (lwkopt 0) (nb 0) (nbmin 0) (nx 0) (lquery nil))
        (declare (type (f2cl-lib:integer4) i ib iinfo iws j ki kk l ldwork
                                           lwkopt nb nbmin nx)
                 (type f2cl-lib:logical lquery))
        (setf info 0)
        (setf nb (ilaenv 1 "DORGQR" " " m n k -1))
        (setf lwkopt
                (f2cl-lib:int-mul
                 (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n))
                 nb))
        (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
                (coerce (the f2cl-lib:integer4 lwkopt) 'double-float))
        (setf lquery (coerce (= lwork -1) 'f2cl-lib:logical))
        (cond
          ((< m 0)
           (setf info -1))
          ((or (< n 0) (> n m))
           (setf info -2))
          ((or (< k 0) (> k n))
           (setf info -3))
          ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
           (setf info -5))
          ((and
            (< lwork (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
            (not lquery))
           (setf info -8)))
        (cond
          ((/= info 0)
           (xerbla "DORGQR" (f2cl-lib:int-sub info))
           (go end_label))
          (lquery
           (go end_label)))
        (cond
          ((<= n 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 nx 0)
        (setf iws n)
        (cond
          ((and (> nb 1) (< nb k))
           (setf nx
                   (max (the f2cl-lib:integer4 0)
                        (the f2cl-lib:integer4
                             (ilaenv 3 "DORGQR" " " m n k -1))))
           (cond
             ((< nx k)
              (setf ldwork n)
              (setf iws (f2cl-lib:int-mul ldwork 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 "DORGQR" " " m n k -1))))))))))
        (cond
          ((and (>= nb nbmin) (< nb k) (< nx k))
           (setf ki (* (the f2cl-lib:integer4 (truncate (- k nx 1) nb)) nb))
           (setf kk
                   (min (the f2cl-lib:integer4 k)
                        (the f2cl-lib:integer4 (f2cl-lib:int-add ki nb))))
           (f2cl-lib:fdo (j (f2cl-lib:int-add kk 1) (f2cl-lib:int-add j 1))
                         ((> j n) nil)
             (tagbody
               (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
                             ((> i kk) nil)
                 (tagbody
                   (setf (f2cl-lib:fref a-%data%
                                        (i j)
                                        ((1 lda) (1 *))
                                        a-%offset%)
                           zero)
                  label10))
              label20)))
          (t
           (setf kk 0)))
        (if (< kk n)
            (multiple-value-bind
                  (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
                (dorg2r (f2cl-lib:int-sub m kk) (f2cl-lib:int-sub n kk)
                 (f2cl-lib:int-sub k kk)
                 (f2cl-lib:array-slice a
                                       double-float
                                       ((+ kk 1) (f2cl-lib:int-add kk 1))
                                       ((1 lda) (1 *)))
                 lda (f2cl-lib:array-slice tau double-float ((+ kk 1)) ((1 *)))
                 work iinfo)
              (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6))
              (setf iinfo var-7)))
        (cond
          ((> kk 0)
           (f2cl-lib:fdo (i (f2cl-lib:int-add ki 1)
                          (f2cl-lib:int-add i (f2cl-lib:int-sub nb)))
                         ((> i 1) 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))))
               (cond
                 ((<= (f2cl-lib:int-add i ib) n)
                  (dlarft "Forward" "Columnwise"
                   (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) ib
                   (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *)))
                   lda (f2cl-lib:array-slice tau double-float (i) ((1 *))) work
                   ldwork)
                  (dlarfb "Left" "No transpose" "Forward" "Columnwise"
                   (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1)
                   (f2cl-lib:int-add (f2cl-lib:int-sub n i ib) 1) ib
                   (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *)))
                   lda work ldwork
                   (f2cl-lib:array-slice a
                                         double-float
                                         (i (f2cl-lib:int-add i ib))
                                         ((1 lda) (1 *)))
                   lda
                   (f2cl-lib:array-slice work double-float ((+ ib 1)) ((1 *)))
                   ldwork)))
               (multiple-value-bind
                     (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
                   (dorg2r (f2cl-lib:int-add (f2cl-lib:int-sub m i) 1) ib ib
                    (f2cl-lib:array-slice a double-float (i i) ((1 lda) (1 *)))
                    lda (f2cl-lib:array-slice tau double-float (i) ((1 *)))
                    work iinfo)
                 (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6))
                 (setf iinfo var-7))
               (f2cl-lib:fdo (j i (f2cl-lib:int-add j 1))
                             ((> j
                                 (f2cl-lib:int-add i ib (f2cl-lib:int-sub 1)))
                              nil)
                 (tagbody
                   (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
                                 ((> l
                                     (f2cl-lib:int-add i (f2cl-lib:int-sub 1)))
                                  nil)
                     (tagbody
                       (setf (f2cl-lib:fref a-%data%
                                            (l j)
                                            ((1 lda) (1 *))
                                            a-%offset%)
                               zero)
                      label30))
                  label40))
              label50))))
        (setf (f2cl-lib:fref work-%data% (1) ((1 *)) work-%offset%)
                (coerce (the f2cl-lib:integer4 iws) 'double-float))
        (go end_label)
       end_label
        (return (values 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::dorgqr
                 fortran-to-lisp::*f2cl-function-info*)
          (fortran-to-lisp::make-f2cl-finfo
           :arg-types '((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)
                        (fortran-to-lisp::integer4))
           :return-values '(nil nil nil nil nil nil nil nil
                            fortran-to-lisp::info)
           :calls '(fortran-to-lisp::dlarfb fortran-to-lisp::dlarft
                    fortran-to-lisp::dorg2r fortran-to-lisp::xerbla
                    fortran-to-lisp::ilaenv))))

