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