share/lapack/blas/zgerc.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 zgerc (m n alpha x incx y incy a lda)
  23     (declare (type (array f2cl-lib:complex16 (*)) a y x)
  24              (type (f2cl-lib:complex16) alpha)
  25              (type (f2cl-lib:integer4) lda incy incx n m))
  26     (f2cl-lib:with-multi-array-data
  27         ((x f2cl-lib:complex16 x-%data% x-%offset%)
  28          (y f2cl-lib:complex16 y-%data% y-%offset%)
  29          (a f2cl-lib:complex16 a-%data% a-%offset%))
  30       (prog ((i 0) (info 0) (ix 0) (j 0) (jy 0) (kx 0) (temp #C(0.0 0.0)))
  31         (declare (type (f2cl-lib:integer4) i info ix j jy kx)
  32                  (type (f2cl-lib:complex16) temp))
  33         (setf info 0)
  34         (cond
  35           ((< m 0)
  36            (setf info 1))
  37           ((< n 0)
  38            (setf info 2))
  39           ((= incx 0)
  40            (setf info 5))
  41           ((= incy 0)
  42            (setf info 7))
  43           ((< lda (max (the f2cl-lib:integer4 1) (the f2cl-lib:integer4 m)))
  44            (setf info 9)))
  45         (cond
  46           ((/= info 0)
  47            (xerbla "ZGERC " info)
  48            (go end_label)))
  49         (if (or (= m 0) (= n 0) (= alpha zero)) (go end_label))
  50         (cond
  51           ((> incy 0)
  52            (setf jy 1))
  53           (t
  54            (setf jy
  55                    (f2cl-lib:int-sub 1
  56                                      (f2cl-lib:int-mul (f2cl-lib:int-sub n 1)
  57                                                        incy)))))
  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 y (jy) ((1 *))) zero)
  65                   (setf temp
  66                           (* alpha
  67                              (f2cl-lib:dconjg
  68                               (f2cl-lib:fref y-%data%
  69                                              (jy)
  70                                              ((1 *))
  71                                              y-%offset%))))
  72                   (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  73                                 ((> i m) nil)
  74                     (tagbody
  75                       (setf (f2cl-lib:fref a-%data%
  76                                            (i j)
  77                                            ((1 lda) (1 *))
  78                                            a-%offset%)
  79                               (+
  80                                (f2cl-lib:fref a-%data%
  81                                               (i j)
  82                                               ((1 lda) (1 *))
  83                                               a-%offset%)
  84                                (*
  85                                 (f2cl-lib:fref x-%data% (i) ((1 *)) x-%offset%)
  86                                 temp)))
  87                      label10))))
  88                (setf jy (f2cl-lib:int-add jy incy))
  89               label20)))
  90           (t
  91            (cond
  92              ((> incx 0)
  93               (setf kx 1))
  94              (t
  95               (setf kx
  96                       (f2cl-lib:int-sub 1
  97                                         (f2cl-lib:int-mul
  98                                          (f2cl-lib:int-sub m 1)
  99                                          incx)))))
 100            (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
 101                          ((> j n) nil)
 102              (tagbody
 103                (cond
 104                  ((/= (f2cl-lib:fref y (jy) ((1 *))) zero)
 105                   (setf temp
 106                           (* alpha
 107                              (f2cl-lib:dconjg
 108                               (f2cl-lib:fref y-%data%
 109                                              (jy)
 110                                              ((1 *))
 111                                              y-%offset%))))
 112                   (setf ix kx)
 113                   (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 114                                 ((> i m) nil)
 115                     (tagbody
 116                       (setf (f2cl-lib:fref a-%data%
 117                                            (i j)
 118                                            ((1 lda) (1 *))
 119                                            a-%offset%)
 120                               (+
 121                                (f2cl-lib:fref a-%data%
 122                                               (i j)
 123                                               ((1 lda) (1 *))
 124                                               a-%offset%)
 125                                (*
 126                                 (f2cl-lib:fref x-%data%
 127                                                (ix)
 128                                                ((1 *))
 129                                                x-%offset%)
 130                                 temp)))
 131                       (setf ix (f2cl-lib:int-add ix incx))
 132                      label30))))
 133                (setf jy (f2cl-lib:int-add jy incy))
 134               label40))))
 135         (go end_label)
 136        end_label
 137         (return (values nil nil nil nil nil nil nil nil nil))))))
 138
 139 (in-package #-gcl #:cl-user #+gcl "CL-USER")
 140 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 141 (eval-when (:load-toplevel :compile-toplevel :execute)
 142   (setf (gethash 'fortran-to-lisp::zgerc fortran-to-lisp::*f2cl-function-info*)
 143           (fortran-to-lisp::make-f2cl-finfo
 144            :arg-types '((fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 145                         (fortran-to-lisp::complex16)
 146                         (array fortran-to-lisp::complex16 (*))
 147                         (fortran-to-lisp::integer4)
 148                         (array fortran-to-lisp::complex16 (*))
 149                         (fortran-to-lisp::integer4)
 150                         (array fortran-to-lisp::complex16 (*))
 151                         (fortran-to-lisp::integer4))
 152            :return-values '(nil nil nil nil nil nil nil nil nil)
 153            :calls '(fortran-to-lisp::xerbla))))
 154