share/lapack/blas/dger.lisp

   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 dger (m n alpha x incx y incy a lda)
  23     (declare (type (array double-float (*)) a y x)
  24              (type (double-float) alpha)
  25              (type (f2cl-lib:integer4) lda incy incx n m))
  26     (f2cl-lib:with-multi-array-data
  27         ((x double-float x-%data% x-%offset%)
  28          (y double-float y-%data% y-%offset%)
  29          (a double-float a-%data% a-%offset%))
  30       (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp 0.0))
  31         (declare (type (f2cl-lib:integer4) i info ix j jy kx)
  32                  (type (double-float) temp))
  33         (setf info 0)
  34         (cond
  35           ((< m 0)
  36            (setf info 1))
  37           ((< n 0)
  38            (setf info 2))
  39           ((= incx 0)
  40            (setf info 5))
  41           ((= incy 0)
  42            (setf info 7))
  43           ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
  44            (setf info 9)))
  45         (cond
  46           ((/= info 0)
  47            (xerbla "DGER  " info)
  48            (go end_label)))
  49         (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label))
  50         (cond
  51           ((> incy 0)
  52            (setf jy 1))
  53           (t
  54            (setf jy
  55                    (f2cl-lib:int-sub 1
  56                                      (f2cl-lib:int-mul (f2cl-lib:int-sub n 1)
  57                                                        incy)))))
  58         (cond
  59           ((= incx 1)
  60            (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  61                          ((> j n) nil)
  62              (tagbody
  63                (cond
  64                  ((/= (f2cl-lib:fref y (jy) ((1 *))) zero)
  65                   (setf temp
  66                           (* alpha
  67                              (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%)))
  68                   (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  69                                 ((> i m) nil)
  70                     (tagbody
  71                       (setf (f2cl-lib:fref a-%data%
  72                                            (i j)
  73                                            ((1 lda) (1 *))
  74                                            a-%offset%)
  75                               (+
  76                                (f2cl-lib:fref a-%data%
  77                                               (i j)
  78                                               ((1 lda) (1 *))
  79                                               a-%offset%)
  80                                (*
  81                                 (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)
  82                                 temp)))
  83                      label10))))
  84                (setf jy (f2cl-lib:int-add jy incy))
  85               label20)))
  86           (t
  87            (cond
  88              ((> incx 0)
  89               (setf kx 1))
  90              (t
  91               (setf kx
  92                       (f2cl-lib:int-sub 1
  93                                         (f2cl-lib:int-mul
  94                                          (f2cl-lib:int-sub m 1)
  95                                          incx)))))
  96            (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  97                          ((> j n) nil)
  98              (tagbody
  99                (cond
 100                  ((/= (f2cl-lib:fref y (jy) ((1 *))) zero)
 101                   (setf temp
 102                           (* alpha
 103                              (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%)))
 104                   (setf ix kx)
 105                   (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 106                                 ((> i m) nil)
 107                     (tagbody
 108                       (setf (f2cl-lib:fref a-%data%
 109                                            (i j)
 110                                            ((1 lda) (1 *))
 111                                            a-%offset%)
 112                               (+
 113                                (f2cl-lib:fref a-%data%
 114                                               (i j)
 115                                               ((1 lda) (1 *))
 116                                               a-%offset%)
 117                                (*
 118                                 (f2cl-lib:fref x-%data%
 119                                                (ix)
 120                                                ((1 *))
 121                                                x-%offset%)
 122                                 temp)))
 123                       (setf ix (f2cl-lib:int-add ix incx))
 124                      label30))))
 125                (setf jy (f2cl-lib:int-add jy incy))
 126               label40))))
 127         (go end_label)
 128        end_label
 129         (return (values nil nil nil nil nil nil nil nil nil))))))
 130
 131 (in-package #:cl-user)
 132 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 133 (eval-when (:load-toplevel :compile-toplevel :execute)
 134   (setf (gethash 'fortran-to-lisp::dger fortran-to-lisp::*f2cl-function-info*)
 135           (fortran-to-lisp::make-f2cl-finfo
 136            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 137                         (double-float) (array double-float (*))
 138                         (fortran-to-lisp::integer4) (array double-float (*))
 139                         (fortran-to-lisp::integer4) (array double-float (*))
 140                         (fortran-to-lisp::integer4))
 141            :return-values '(nil nil nil nil nil nil nil nil nil)
 142            :calls '(fortran-to-lisp::xerbla))))
 143