share/lapack/blas/dsyr2k.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 dsyr2k (uplo trans n k alpha a lda b ldb$ beta c ldc)
  25     (declare (type (array double-float (*)) c b a)
  26              (type (double-float) beta alpha)
  27              (type (f2cl-lib:integer4) ldc ldb$ lda k n)
  28              (type (simple-string *) trans uplo))
  29     (f2cl-lib:with-multi-array-data
  30         ((uplo character uplo-%data% uplo-%offset%)
  31          (trans character trans-%data% trans-%offset%)
  32          (a double-float a-%data% a-%offset%)
  33          (b double-float b-%data% b-%offset%)
  34          (c double-float c-%data% c-%offset%))
  35       (prog ((temp1 0.0) (temp2 0.0) (i 0) (info 0) (j 0) (l 0) (nrowa 0)
  36              (upper nil))
  37         (declare (type (double-float) temp1 temp2)
  38                  (type (f2cl-lib:integer4) i info j l nrowa)
  39                  (type f2cl-lib:logical upper))
  40         (cond
  41           ((lsame trans "N")
  42            (setf nrowa n))
  43           (t
  44            (setf nrowa k)))
  45         (setf upper (lsame uplo "U"))
  46         (setf info 0)
  47         (cond
  48           ((and (not upper) (not (lsame uplo "L")))
  49            (setf info 1))
  50           ((and (not (lsame trans "N"))
  51                 (not (lsame trans "T"))
  52                 (not (lsame trans "C")))
  53            (setf info 2))
  54           ((< n 0)
  55            (setf info 3))
  56           ((< k 0)
  57            (setf info 4))
  58           ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa)))
  59            (setf info 7))
  60           ((< ldb$
  61               (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 nrowa)))
  62            (setf info 9))
  63           ((< ldc (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 n)))
  64            (setf info 12)))
  65         (cond
  66           ((/= info 0)
  67            (xerbla "DSYR2K" info)
  68            (go end_label)))
  69         (if (or (= n 0) (and (or (= alpha zero) (= k 0)) (= beta one)))
  70             (go end_label))
  71         (cond
  72           ((= alpha zero)
  73            (cond
  74              (upper
  75               (cond
  76                 ((= beta zero)
  77                  (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  78                                ((> j n) nil)
  79                    (tagbody
  80                      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  81                                    ((> i j) nil)
  82                        (tagbody
  83                          (setf (f2cl-lib:fref c-%data%
  84                                               (i j)
  85                                               ((1 ldc) (1 *))
  86                                               c-%offset%)
  87                                  zero)
  88                         label10))
  89                     label20)))
  90                 (t
  91                  (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
  92                                ((> j n) nil)
  93                    (tagbody
  94                      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  95                                    ((> i j) nil)
  96                        (tagbody
  97                          (setf (f2cl-lib:fref c-%data%
  98                                               (i j)
  99                                               ((1 ldc) (1 *))
 100                                               c-%offset%)
 101                                  (* beta
 102                                     (f2cl-lib:fref c-%data%
 103                                                    (i j)
 104                                                    ((1 ldc) (1 *))
 105                                                    c-%offset%)))
 106                         label30))
 107                     label40)))))
 108              (t
 109               (cond
 110                 ((= beta zero)
 111                  (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 112                                ((> j n) nil)
 113                    (tagbody
 114                      (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
 115                                    ((> i n) nil)
 116                        (tagbody
 117                          (setf (f2cl-lib:fref c-%data%
 118                                               (i j)
 119                                               ((1 ldc) (1 *))
 120                                               c-%offset%)
 121                                  zero)
 122                         label50))
 123                     label60)))
 124                 (t
 125                  (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 126                                ((> j n) nil)
 127                    (tagbody
 128                      (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
 129                                    ((> i n) nil)
 130                        (tagbody
 131                          (setf (f2cl-lib:fref c-%data%
 132                                               (i j)
 133                                               ((1 ldc) (1 *))
 134                                               c-%offset%)
 135                                  (* beta
 136                                     (f2cl-lib:fref c-%data%
 137                                                    (i j)
 138                                                    ((1 ldc) (1 *))
 139                                                    c-%offset%)))
 140                         label70))
 141                     label80))))))
 142            (go end_label)))
 143         (cond
 144           ((lsame trans "N")
 145            (cond
 146              (upper
 147               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 148                             ((> j n) nil)
 149                 (tagbody
 150                   (cond
 151                     ((= beta zero)
 152                      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 153                                    ((> i j) nil)
 154                        (tagbody
 155                          (setf (f2cl-lib:fref c-%data%
 156                                               (i j)
 157                                               ((1 ldc) (1 *))
 158                                               c-%offset%)
 159                                  zero)
 160                         label90)))
 161                     ((/= beta one)
 162                      (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 163                                    ((> i j) nil)
 164                        (tagbody
 165                          (setf (f2cl-lib:fref c-%data%
 166                                               (i j)
 167                                               ((1 ldc) (1 *))
 168                                               c-%offset%)
 169                                  (* beta
 170                                     (f2cl-lib:fref c-%data%
 171                                                    (i j)
 172                                                    ((1 ldc) (1 *))
 173                                                    c-%offset%)))
 174                         label100))))
 175                   (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 176                                 ((> l k) nil)
 177                     (tagbody
 178                       (cond
 179                         ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero)
 180                              (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero))
 181                          (setf temp1
 182                                  (* alpha
 183                                     (f2cl-lib:fref b-%data%
 184                                                    (j l)
 185                                                    ((1 ldb$) (1 *))
 186                                                    b-%offset%)))
 187                          (setf temp2
 188                                  (* alpha
 189                                     (f2cl-lib:fref a-%data%
 190                                                    (j l)
 191                                                    ((1 lda) (1 *))
 192                                                    a-%offset%)))
 193                          (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 194                                        ((> i j) nil)
 195                            (tagbody
 196                              (setf (f2cl-lib:fref c-%data%
 197                                                   (i j)
 198                                                   ((1 ldc) (1 *))
 199                                                   c-%offset%)
 200                                      (+
 201                                       (f2cl-lib:fref c-%data%
 202                                                      (i j)
 203                                                      ((1 ldc) (1 *))
 204                                                      c-%offset%)
 205                                       (*
 206                                        (f2cl-lib:fref a-%data%
 207                                                       (i l)
 208                                                       ((1 lda) (1 *))
 209                                                       a-%offset%)
 210                                        temp1)
 211                                       (*
 212                                        (f2cl-lib:fref b-%data%
 213                                                       (i l)
 214                                                       ((1 ldb$) (1 *))
 215                                                       b-%offset%)
 216                                        temp2)))
 217                             label110))))
 218                      label120))
 219                  label130)))
 220              (t
 221               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 222                             ((> j n) nil)
 223                 (tagbody
 224                   (cond
 225                     ((= beta zero)
 226                      (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
 227                                    ((> i n) nil)
 228                        (tagbody
 229                          (setf (f2cl-lib:fref c-%data%
 230                                               (i j)
 231                                               ((1 ldc) (1 *))
 232                                               c-%offset%)
 233                                  zero)
 234                         label140)))
 235                     ((/= beta one)
 236                      (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
 237                                    ((> i n) nil)
 238                        (tagbody
 239                          (setf (f2cl-lib:fref c-%data%
 240                                               (i j)
 241                                               ((1 ldc) (1 *))
 242                                               c-%offset%)
 243                                  (* beta
 244                                     (f2cl-lib:fref c-%data%
 245                                                    (i j)
 246                                                    ((1 ldc) (1 *))
 247                                                    c-%offset%)))
 248                         label150))))
 249                   (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 250                                 ((> l k) nil)
 251                     (tagbody
 252                       (cond
 253                         ((or (/= (f2cl-lib:fref a (j l) ((1 lda) (1 *))) zero)
 254                              (/= (f2cl-lib:fref b (j l) ((1 ldb$) (1 *))) zero))
 255                          (setf temp1
 256                                  (* alpha
 257                                     (f2cl-lib:fref b-%data%
 258                                                    (j l)
 259                                                    ((1 ldb$) (1 *))
 260                                                    b-%offset%)))
 261                          (setf temp2
 262                                  (* alpha
 263                                     (f2cl-lib:fref a-%data%
 264                                                    (j l)
 265                                                    ((1 lda) (1 *))
 266                                                    a-%offset%)))
 267                          (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
 268                                        ((> i n) nil)
 269                            (tagbody
 270                              (setf (f2cl-lib:fref c-%data%
 271                                                   (i j)
 272                                                   ((1 ldc) (1 *))
 273                                                   c-%offset%)
 274                                      (+
 275                                       (f2cl-lib:fref c-%data%
 276                                                      (i j)
 277                                                      ((1 ldc) (1 *))
 278                                                      c-%offset%)
 279                                       (*
 280                                        (f2cl-lib:fref a-%data%
 281                                                       (i l)
 282                                                       ((1 lda) (1 *))
 283                                                       a-%offset%)
 284                                        temp1)
 285                                       (*
 286                                        (f2cl-lib:fref b-%data%
 287                                                       (i l)
 288                                                       ((1 ldb$) (1 *))
 289                                                       b-%offset%)
 290                                        temp2)))
 291                             label160))))
 292                      label170))
 293                  label180)))))
 294           (t
 295            (cond
 296              (upper
 297               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 298                             ((> j n) nil)
 299                 (tagbody
 300                   (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 301                                 ((> i j) nil)
 302                     (tagbody
 303                       (setf temp1 zero)
 304                       (setf temp2 zero)
 305                       (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 306                                     ((> l k) nil)
 307                         (tagbody
 308                           (setf temp1
 309                                   (+ temp1
 310                                      (*
 311                                       (f2cl-lib:fref a-%data%
 312                                                      (l i)
 313                                                      ((1 lda) (1 *))
 314                                                      a-%offset%)
 315                                       (f2cl-lib:fref b-%data%
 316                                                      (l j)
 317                                                      ((1 ldb$) (1 *))
 318                                                      b-%offset%))))
 319                           (setf temp2
 320                                   (+ temp2
 321                                      (*
 322                                       (f2cl-lib:fref b-%data%
 323                                                      (l i)
 324                                                      ((1 ldb$) (1 *))
 325                                                      b-%offset%)
 326                                       (f2cl-lib:fref a-%data%
 327                                                      (l j)
 328                                                      ((1 lda) (1 *))
 329                                                      a-%offset%))))
 330                          label190))
 331                       (cond
 332                         ((= beta zero)
 333                          (setf (f2cl-lib:fref c-%data%
 334                                               (i j)
 335                                               ((1 ldc) (1 *))
 336                                               c-%offset%)
 337                                  (+ (* alpha temp1) (* alpha temp2))))
 338                         (t
 339                          (setf (f2cl-lib:fref c-%data%
 340                                               (i j)
 341                                               ((1 ldc) (1 *))
 342                                               c-%offset%)
 343                                  (+
 344                                   (* beta
 345                                      (f2cl-lib:fref c-%data%
 346                                                     (i j)
 347                                                     ((1 ldc) (1 *))
 348                                                     c-%offset%))
 349                                   (* alpha temp1)
 350                                   (* alpha temp2)))))
 351                      label200))
 352                  label210)))
 353              (t
 354               (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 355                             ((> j n) nil)
 356                 (tagbody
 357                   (f2cl-lib:fdo (i j (f2cl-lib:int-add i 1))
 358                                 ((> i n) nil)
 359                     (tagbody
 360                       (setf temp1 zero)
 361                       (setf temp2 zero)
 362                       (f2cl-lib:fdo (l 1 (f2cl-lib:int-add l 1))
 363                                     ((> l k) nil)
 364                         (tagbody
 365                           (setf temp1
 366                                   (+ temp1
 367                                      (*
 368                                       (f2cl-lib:fref a-%data%
 369                                                      (l i)
 370                                                      ((1 lda) (1 *))
 371                                                      a-%offset%)
 372                                       (f2cl-lib:fref b-%data%
 373                                                      (l j)
 374                                                      ((1 ldb$) (1 *))
 375                                                      b-%offset%))))
 376                           (setf temp2
 377                                   (+ temp2
 378                                      (*
 379                                       (f2cl-lib:fref b-%data%
 380                                                      (l i)
 381                                                      ((1 ldb$) (1 *))
 382                                                      b-%offset%)
 383                                       (f2cl-lib:fref a-%data%
 384                                                      (l j)
 385                                                      ((1 lda) (1 *))
 386                                                      a-%offset%))))
 387                          label220))
 388                       (cond
 389                         ((= beta zero)
 390                          (setf (f2cl-lib:fref c-%data%
 391                                               (i j)
 392                                               ((1 ldc) (1 *))
 393                                               c-%offset%)
 394                                  (+ (* alpha temp1) (* alpha temp2))))
 395                         (t
 396                          (setf (f2cl-lib:fref c-%data%
 397                                               (i j)
 398                                               ((1 ldc) (1 *))
 399                                               c-%offset%)
 400                                  (+
 401                                   (* beta
 402                                      (f2cl-lib:fref c-%data%
 403                                                     (i j)
 404                                                     ((1 ldc) (1 *))
 405                                                     c-%offset%))
 406                                   (* alpha temp1)
 407                                   (* alpha temp2)))))
 408                      label230))
 409                  label240))))))
 410         (go end_label)
 411        end_label
 412         (return (values nil nil nil nil nil nil nil nil nil nil nil nil))))))
 413
 414 (in-package #:cl-user)
 415 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 416 (eval-when (:load-toplevel :compile-toplevel :execute)
 417   (setf (gethash 'fortran-to-lisp::dsyr2k
 418                  fortran-to-lisp::*f2cl-function-info*)
 419           (fortran-to-lisp::make-f2cl-finfo
 420            :arg-types '((simple-string) (simple-string)
 421                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 422                         (double-float) (array double-float (*))
 423                         (fortran-to-lisp::integer4) (array double-float (*))
 424                         (fortran-to-lisp::integer4) (double-float)
 425                         (array double-float (*)) (fortran-to-lisp::integer4))
 426            :return-values '(nil nil nil nil nil nil nil nil nil nil nil nil)
 427            :calls '(fortran-to-lisp::xerbla fortran-to-lisp::lsame))))
 428