share/lapack/blas/dspr.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 dspr (uplo n alpha x incx ap)
  23     (declare (type (array double-float (*)) ap x)
  24              (type (double-float) alpha)
  25              (type (f2cl-lib:integer4) incx n)
  26              (type (simple-string *) uplo))
  27     (f2cl-lib:with-multi-array-data
  28         ((uplo character uplo-%data% uplo-%offset%)
  29          (x double-float x-%data% x-%offset%)
  30          (ap double-float ap-%data% ap-%offset%))
  31       (prog ((i 0) (info 0) (ix 0) (j 0) (jx 0) (k 0) (kk 0) (kx 0) (temp 0.0))
  32         (declare (type (f2cl-lib:integer4) i info ix j jx k kk kx)
  33                  (type (double-float) temp))
  34         (setf info 0)
  35         (cond
  36           ((and (not (lsame uplo "U")) (not (lsame uplo "L")))
  37            (setf info 1))
  38           ((< n 0)
  39            (setf info 2))
  40           ((= incx 0)
  41            (setf info 5)))
  42         (cond
  43           ((/= info 0)
  44            (xerbla "DSPR  " info)
  45            (go end_label)))
  46         (if (or (= n 0) (= alpha zero)) (go end_label))
  47         (cond
  48           ((<= incx 0)
  49            (setf kx
  50                    (f2cl-lib:int-sub 1
  51                                      (f2cl-lib:int-mul (f2cl-lib:int-sub n 1)
  52                                                        incx))))
  53           ((/= incx 1)
  54            (setf kx 1)))
  55         (setf kk 1)
  56         (cond
  57           ((lsame uplo "U")
  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 x (j) ((1 *))) zero)
  65                      (setf temp
  66                              (* alpha
  67                                 (f2cl-lib:fref x-%data%
  68                                                (j)
  69                                                ((1 *))
  70                                                x-%offset%)))
  71                      (setf k kk)
  72                      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  73                                    ((> i j) nil)
  74                        (tagbody
  75                          (setf (f2cl-lib:fref ap-%data%
  76                                               (k)
  77                                               ((1 *))
  78                                               ap-%offset%)
  79                                  (+
  80                                   (f2cl-lib:fref ap-%data%
  81                                                  (k)
  82                                                  ((1 *))
  83                                                  ap-%offset%)
  84                                   (*
  85                                    (f2cl-lib:fref x-%data%
  86                                                   (i)
  87                                                   ((1 *))
  88                                                   x-%offset%)
  89                                    temp)))
  90                          (setf k (f2cl-lib:int-add k 1))
  91                         label10))))
  92                   (setf kk (f2cl-lib:int-add kk j))
  93                  label20)))
  94              (t
  95               (setf jx kx)
  96               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  97                             ((> j n) nil)
  98                 (tagbody
  99                   (cond
 100                     ((/= (f2cl-lib:fref x (jx) ((1 *))) zero)
 101                      (setf temp
 102                              (* alpha
 103                                 (f2cl-lib:fref x-%data%
 104                                                (jx)
 105                                                ((1 *))
 106                                                x-%offset%)))
 107                      (setf ix kx)
 108                      (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1))
 109                                    ((> k
 110                                        (f2cl-lib:int-add kk
 111                                                          j
 112                                                          (f2cl-lib:int-sub 1)))
 113                                     nil)
 114                        (tagbody
 115                          (setf (f2cl-lib:fref ap-%data%
 116                                               (k)
 117                                               ((1 *))
 118                                               ap-%offset%)
 119                                  (+
 120                                   (f2cl-lib:fref ap-%data%
 121                                                  (k)
 122                                                  ((1 *))
 123                                                  ap-%offset%)
 124                                   (*
 125                                    (f2cl-lib:fref x-%data%
 126                                                   (ix)
 127                                                   ((1 *))
 128                                                   x-%offset%)
 129                                    temp)))
 130                          (setf ix (f2cl-lib:int-add ix incx))
 131                         label30))))
 132                   (setf jx (f2cl-lib:int-add jx incx))
 133                   (setf kk (f2cl-lib:int-add kk j))
 134                  label40)))))
 135           (t
 136            (cond
 137              ((= incx 1)
 138               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 139                             ((> j n) nil)
 140                 (tagbody
 141                   (cond
 142                     ((/= (f2cl-lib:fref x (j) ((1 *))) zero)
 143                      (setf temp
 144                              (* alpha
 145                                 (f2cl-lib:fref x-%data%
 146                                                (j)
 147                                                ((1 *))
 148                                                x-%offset%)))
 149                      (setf k kk)
 150                      (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
 151                                    ((> i n) nil)
 152                        (tagbody
 153                          (setf (f2cl-lib:fref ap-%data%
 154                                               (k)
 155                                               ((1 *))
 156                                               ap-%offset%)
 157                                  (+
 158                                   (f2cl-lib:fref ap-%data%
 159                                                  (k)
 160                                                  ((1 *))
 161                                                  ap-%offset%)
 162                                   (*
 163                                    (f2cl-lib:fref x-%data%
 164                                                   (i)
 165                                                   ((1 *))
 166                                                   x-%offset%)
 167                                    temp)))
 168                          (setf k (f2cl-lib:int-add k 1))
 169                         label50))))
 170                   (setf kk
 171                           (f2cl-lib:int-add
 172                            (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j)
 173                            1))
 174                  label60)))
 175              (t
 176               (setf jx kx)
 177               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 178                             ((> j n) nil)
 179                 (tagbody
 180                   (cond
 181                     ((/= (f2cl-lib:fref x (jx) ((1 *))) zero)
 182                      (setf temp
 183                              (* alpha
 184                                 (f2cl-lib:fref x-%data%
 185                                                (jx)
 186                                                ((1 *))
 187                                                x-%offset%)))
 188                      (setf ix jx)
 189                      (f2cl-lib:fdo (k kk (f2cl-lib:int-add k 1))
 190                                    ((> k
 191                                        (f2cl-lib:int-add kk
 192                                                          n
 193                                                          (f2cl-lib:int-sub j)))
 194                                     nil)
 195                        (tagbody
 196                          (setf (f2cl-lib:fref ap-%data%
 197                                               (k)
 198                                               ((1 *))
 199                                               ap-%offset%)
 200                                  (+
 201                                   (f2cl-lib:fref ap-%data%
 202                                                  (k)
 203                                                  ((1 *))
 204                                                  ap-%offset%)
 205                                   (*
 206                                    (f2cl-lib:fref x-%data%
 207                                                   (ix)
 208                                                   ((1 *))
 209                                                   x-%offset%)
 210                                    temp)))
 211                          (setf ix (f2cl-lib:int-add ix incx))
 212                         label70))))
 213                   (setf jx (f2cl-lib:int-add jx incx))
 214                   (setf kk
 215                           (f2cl-lib:int-add
 216                            (f2cl-lib:int-sub (f2cl-lib:int-add kk n) j)
 217                            1))
 218                  label80))))))
 219         (go end_label)
 220        end_label
 221         (return (values nil nil nil nil nil nil))))))
 222
 223 (in-package #-gcl #:cl-user #+gcl "CL-USER")
 224 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 225 (eval-when (:load-toplevel :compile-toplevel :execute)
 226   (setf (gethash 'fortran-to-lisp::dspr fortran-to-lisp::*f2cl-function-info*)
 227           (fortran-to-lisp::make-f2cl-finfo
 228            :arg-types '((simple-string) (fortran-to-lisp::integer4)
 229                         (double-float) (array double-float (*))
 230                         (fortran-to-lisp::integer4) (array double-float (*)))
 231            :return-values '(nil nil nil nil nil nil)
 232            :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))))
 233