share/lapack/blas/zrotg.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 (defun zrotg (ca cb c s)
  21   (declare (type (double-float) c) (type (f2cl-lib:complex16) s cb ca))
  22   (prog ((alpha #C(0.0 0.0)) (norm 0.0) (scale 0.0))
  23     (declare (type (double-float) scale norm)
  24              (type (f2cl-lib:complex16) alpha))
  25     (if (/= (f2cl-lib:cdabs ca) 0.0) (go label10))
  26     (setf c 0.0)
  27     (setf s (f2cl-lib:cmplx 1.0 0.0))
  28     (setf ca cb)
  29     (go label20)
  30    label10
  31     (setf scale
  32             (coerce (+ (f2cl-lib:cdabs ca) (f2cl-lib:cdabs cb)) 'double-float))
  33     (setf norm
  34             (* scale
  35                (f2cl-lib:dsqrt
  36                 (+ (expt (f2cl-lib:cdabs (/ ca (f2cl-lib:dcmplx scale 0.0))) 2)
  37                    (expt (f2cl-lib:cdabs (/ cb (f2cl-lib:dcmplx scale 0.0)))
  38                          2)))))
  39     (setf alpha (/ ca (f2cl-lib:cdabs ca)))
  40     (setf c (/ (f2cl-lib:cdabs ca) norm))
  41     (setf s (/ (* alpha (f2cl-lib:dconjg cb)) norm))
  42     (setf ca (* alpha norm))
  43    label20
  44     (go end_label)
  45    end_label
  46     (return (values ca nil c s))))
  47
  48 (in-package #-gcl #:cl-user #+gcl "CL-USER")
  49 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  50 (eval-when (:load-toplevel :compile-toplevel :execute)
  51   (setf (gethash 'fortran-to-lisp::zrotg fortran-to-lisp::*f2cl-function-info*)
  52           (fortran-to-lisp::make-f2cl-finfo
  53            :arg-types '((fortran-to-lisp::complex16)
  54                         (fortran-to-lisp::complex16) (double-float)
  55                         (fortran-to-lisp::complex16))
  56            :return-values '(fortran-to-lisp::ca nil fortran-to-lisp::c
  57                             fortran-to-lisp::s)
  58            :calls 'nil)))
  59