share/lapack/blas/dgbmv.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* ((one 1.0) (zero 0.0))
  21   (declare (type (double-float 1.0 1.0) one)
  22            (type (double-float 0.0 0.0) zero)
  23            (ignorable one zero))
  24   (defun dgbmv (trans m n kl ku alpha a lda x incx beta y incy)
  25     (declare (type (array double-float (*)) y x a)
  26              (type (double-float) beta alpha)
  27              (type (f2cl-lib:integer4) incy incx lda ku kl n m)
  28              (type (simple-string *) trans))
  29     (f2cl-lib:with-multi-array-data
  30         ((trans character trans-%data% trans-%offset%)
  31          (a double-float a-%data% a-%offset%)
  32          (x double-float x-%data% x-%offset%)
  33          (y double-float y-%data% y-%offset%))
  34       (prog ((i 0) (info 0) (ix 0) (iy 0) (j 0) (jx 0) (jy 0) (k 0) (kup1 0)
  35              (kx 0) (ky 0) (lenx 0) (leny 0) (temp 0.0))
  36         (declare (type (f2cl-lib:integer4) i info ix iy j jx jy k kup1 kx ky
  37                                            lenx leny)
  38                  (type (double-float) temp))
  39         (setf info 0)
  40         (cond
  41           ((and (not (lsame trans "N"))
  42                 (not (lsame trans "T"))
  43                 (not (lsame trans "C")))
  44            (setf info 1))
  45           ((< m 0)
  46            (setf info 2))
  47           ((< n 0)
  48            (setf info 3))
  49           ((< kl 0)
  50            (setf info 4))
  51           ((< ku 0)
  52            (setf info 5))
  53           ((< lda (f2cl-lib:int-add kl ku 1))
  54            (setf info 8))
  55           ((= incx 0)
  56            (setf info 10))
  57           ((= incy 0)
  58            (setf info 13)))
  59         (cond
  60           ((/= info 0)
  61            (xerbla "DGBMV " info)
  62            (go end_label)))
  63         (if (or (= m 0) (= n 0) (and (= alpha zero) (= beta one)))
  64             (go end_label))
  65         (cond
  66           ((lsame trans "N")
  67            (setf lenx n)
  68            (setf leny m))
  69           (t
  70            (setf lenx m)
  71            (setf leny n)))
  72         (cond
  73           ((> incx 0)
  74            (setf kx 1))
  75           (t
  76            (setf kx
  77                    (f2cl-lib:int-sub 1
  78                                      (f2cl-lib:int-mul
  79                                       (f2cl-lib:int-sub lenx 1)
  80                                       incx)))))
  81         (cond
  82           ((> incy 0)
  83            (setf ky 1))
  84           (t
  85            (setf ky
  86                    (f2cl-lib:int-sub 1
  87                                      (f2cl-lib:int-mul
  88                                       (f2cl-lib:int-sub leny 1)
  89                                       incy)))))
  90         (cond
  91           ((/= beta one)
  92            (cond
  93              ((= incy 1)
  94               (cond
  95                 ((= beta zero)
  96                  (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  97                                ((> i leny) nil)
  98                    (tagbody
  99                      (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
 100                              zero)
 101                     label10)))
 102                 (t
 103                  (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 104                                ((> i leny) nil)
 105                    (tagbody
 106                      (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
 107                              (* beta
 108                                 (f2cl-lib:fref y-%data%
 109                                                (i)
 110                                                ((1 *))
 111                                                y-%offset%)))
 112                     label20)))))
 113              (t
 114               (setf iy ky)
 115               (cond
 116                 ((= beta zero)
 117                  (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 118                                ((> i leny) nil)
 119                    (tagbody
 120                      (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%)
 121                              zero)
 122                      (setf iy (f2cl-lib:int-add iy incy))
 123                     label30)))
 124                 (t
 125                  (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 126                                ((> i leny) nil)
 127                    (tagbody
 128                      (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%)
 129                              (* beta
 130                                 (f2cl-lib:fref y-%data%
 131                                                (iy)
 132                                                ((1 *))
 133                                                y-%offset%)))
 134                      (setf iy (f2cl-lib:int-add iy incy))
 135                     label40))))))))
 136         (if (= alpha zero) (go end_label))
 137         (setf kup1 (f2cl-lib:int-add ku 1))
 138         (cond
 139           ((lsame trans "N")
 140            (setf jx kx)
 141            (cond
 142              ((= incy 1)
 143               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 144                             ((> j n) nil)
 145                 (tagbody
 146                   (cond
 147                     ((/= (f2cl-lib:fref x (jx) ((1 *))) zero)
 148                      (setf temp
 149                              (* alpha
 150                                 (f2cl-lib:fref x-%data%
 151                                                (jx)
 152                                                ((1 *))
 153                                                x-%offset%)))
 154                      (setf k (f2cl-lib:int-sub kup1 j))
 155                      (f2cl-lib:fdo (i
 156                                     (max (the f2cl-lib:integer4 1)
 157                                          (the f2cl-lib:integer4
 158                                               (f2cl-lib:int-add j
 159                                                                 (f2cl-lib:int-sub
 160                                                                  ku))))
 161                                     (f2cl-lib:int-add i 1))
 162                                    ((> i
 163                                        (min (the f2cl-lib:integer4 m)
 164                                             (the f2cl-lib:integer4
 165                                                  (f2cl-lib:int-add j kl))))
 166                                     nil)
 167                        (tagbody
 168                          (setf (f2cl-lib:fref y-%data% (i) ((1 *)) y-%offset%)
 169                                  (+
 170                                   (f2cl-lib:fref y-%data%
 171                                                  (i)
 172                                                  ((1 *))
 173                                                  y-%offset%)
 174                                   (* temp
 175                                      (f2cl-lib:fref a-%data%
 176                                                     ((f2cl-lib:int-add k i) j)
 177                                                     ((1 lda) (1 *))
 178                                                     a-%offset%))))
 179                         label50))))
 180                   (setf jx (f2cl-lib:int-add jx incx))
 181                  label60)))
 182              (t
 183               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 184                             ((> j n) nil)
 185                 (tagbody
 186                   (cond
 187                     ((/= (f2cl-lib:fref x (jx) ((1 *))) zero)
 188                      (setf temp
 189                              (* alpha
 190                                 (f2cl-lib:fref x-%data%
 191                                                (jx)
 192                                                ((1 *))
 193                                                x-%offset%)))
 194                      (setf iy ky)
 195                      (setf k (f2cl-lib:int-sub kup1 j))
 196                      (f2cl-lib:fdo (i
 197                                     (max (the f2cl-lib:integer4 1)
 198                                          (the f2cl-lib:integer4
 199                                               (f2cl-lib:int-add j
 200                                                                 (f2cl-lib:int-sub
 201                                                                  ku))))
 202                                     (f2cl-lib:int-add i 1))
 203                                    ((> i
 204                                        (min (the f2cl-lib:integer4 m)
 205                                             (the f2cl-lib:integer4
 206                                                  (f2cl-lib:int-add j kl))))
 207                                     nil)
 208                        (tagbody
 209                          (setf (f2cl-lib:fref y-%data% (iy) ((1 *)) y-%offset%)
 210                                  (+
 211                                   (f2cl-lib:fref y-%data%
 212                                                  (iy)
 213                                                  ((1 *))
 214                                                  y-%offset%)
 215                                   (* temp
 216                                      (f2cl-lib:fref a-%data%
 217                                                     ((f2cl-lib:int-add k i) j)
 218                                                     ((1 lda) (1 *))
 219                                                     a-%offset%))))
 220                          (setf iy (f2cl-lib:int-add iy incy))
 221                         label70))))
 222                   (setf jx (f2cl-lib:int-add jx incx))
 223                   (if (> j ku) (setf ky (f2cl-lib:int-add ky incy)))
 224                  label80)))))
 225           (t
 226            (setf jy ky)
 227            (cond
 228              ((= incx 1)
 229               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 230                             ((> j n) nil)
 231                 (tagbody
 232                   (setf temp zero)
 233                   (setf k (f2cl-lib:int-sub kup1 j))
 234                   (f2cl-lib:fdo (i
 235                                  (max (the f2cl-lib:integer4 1)
 236                                       (the f2cl-lib:integer4
 237                                            (f2cl-lib:int-add j
 238                                                              (f2cl-lib:int-sub
 239                                                               ku))))
 240                                  (f2cl-lib:int-add i 1))
 241                                 ((> i
 242                                     (min (the f2cl-lib:integer4 m)
 243                                          (the f2cl-lib:integer4
 244                                               (f2cl-lib:int-add j kl))))
 245                                  nil)
 246                     (tagbody
 247                       (setf temp
 248                               (+ temp
 249                                  (*
 250                                   (f2cl-lib:fref a-%data%
 251                                                  ((f2cl-lib:int-add k i) j)
 252                                                  ((1 lda) (1 *))
 253                                                  a-%offset%)
 254                                   (f2cl-lib:fref x-%data%
 255                                                  (i)
 256                                                  ((1 *))
 257                                                  x-%offset%))))
 258                      label90))
 259                   (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%)
 260                           (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%)
 261                              (* alpha temp)))
 262                   (setf jy (f2cl-lib:int-add jy incy))
 263                  label100)))
 264              (t
 265               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 266                             ((> j n) nil)
 267                 (tagbody
 268                   (setf temp zero)
 269                   (setf ix kx)
 270                   (setf k (f2cl-lib:int-sub kup1 j))
 271                   (f2cl-lib:fdo (i
 272                                  (max (the f2cl-lib:integer4 1)
 273                                       (the f2cl-lib:integer4
 274                                            (f2cl-lib:int-add j
 275                                                              (f2cl-lib:int-sub
 276                                                               ku))))
 277                                  (f2cl-lib:int-add i 1))
 278                                 ((> i
 279                                     (min (the f2cl-lib:integer4 m)
 280                                          (the f2cl-lib:integer4
 281                                               (f2cl-lib:int-add j kl))))
 282                                  nil)
 283                     (tagbody
 284                       (setf temp
 285                               (+ temp
 286                                  (*
 287                                   (f2cl-lib:fref a-%data%
 288                                                  ((f2cl-lib:int-add k i) j)
 289                                                  ((1 lda) (1 *))
 290                                                  a-%offset%)
 291                                   (f2cl-lib:fref x-%data%
 292                                                  (ix)
 293                                                  ((1 *))
 294                                                  x-%offset%))))
 295                       (setf ix (f2cl-lib:int-add ix incx))
 296                      label110))
 297                   (setf (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%)
 298                           (+ (f2cl-lib:fref y-%data% (jy) ((1 *)) y-%offset%)
 299                              (* alpha temp)))
 300                   (setf jy (f2cl-lib:int-add jy incy))
 301                   (if (> j ku) (setf kx (f2cl-lib:int-add kx incx)))
 302                  label120))))))
 303         (go end_label)
 304        end_label
 305         (return
 306          (values nil nil nil nil nil nil nil nil nil nil nil nil nil))))))
 307
 308 (in-package #-gcl #:cl-user #+gcl "CL-USER")
 309 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 310 (eval-when (:load-toplevel :compile-toplevel :execute)
 311   (setf (gethash 'fortran-to-lisp::dgbmv fortran-to-lisp::*f2cl-function-info*)
 312           (fortran-to-lisp::make-f2cl-finfo
 313            :arg-types '((simple-string) (fortran-to-lisp::integer4)
 314                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 315                         (fortran-to-lisp::integer4) (double-float)
 316                         (array double-float (*)) (fortran-to-lisp::integer4)
 317                         (array double-float (*)) (fortran-to-lisp::integer4)
 318                         (double-float) (array double-float (*))
 319                         (fortran-to-lisp::integer4))
 320            :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil
 321                             nil)
 322            :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))))
 323