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