src/numerical/slatec/zs1s2.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 46c1f6a93b0d 2012/05/03 04:40:28 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 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v fceac530ef0c 2011/11/26 04:02:26 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp snapshot-2012-04 (20C Unicode)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  14 ;;;           (:array-slicing nil) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package :slatec)
  18
  19
  20 (let ((zeror 0.0) (zeroi 0.0))
  21   (declare (type (double-float) zeror zeroi))
  22   (defun zs1s2 (zrr zri s1r s1i s2r s2i nz ascle alim iuf)
  23     (declare (type (f2cl-lib:integer4) iuf nz)
  24              (type (double-float) alim ascle s2i s2r s1i s1r zri zrr))
  25     (prog ((idum 0) (aa 0.0) (aln 0.0) (as1 0.0) (as2 0.0) (c1i 0.0) (c1r 0.0)
  26            (s1di 0.0) (s1dr 0.0))
  27       (declare (type (double-float) s1dr s1di c1r c1i as2 as1 aln aa)
  28                (type (f2cl-lib:integer4) idum))
  29       (setf nz 0)
  30       (setf as1 (coerce (realpart (zabs s1r s1i)) 'double-float))
  31       (setf as2 (coerce (realpart (zabs s2r s2i)) 'double-float))
  32       (if (and (= s1r 0.0) (= s1i 0.0)) (go label10))
  33       (if (= as1 0.0) (go label10))
  34       (setf aln (+ (- (- zrr) zrr) (f2cl-lib:flog as1)))
  35       (setf s1dr s1r)
  36       (setf s1di s1i)
  37       (setf s1r zeror)
  38       (setf s1i zeroi)
  39       (setf as1 zeror)
  40       (if (< aln (- alim)) (go label10))
  41       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
  42           (zlog s1dr s1di c1r c1i idum)
  43         (declare (ignore var-0 var-1))
  44         (setf c1r var-2)
  45         (setf c1i var-3)
  46         (setf idum var-4))
  47       (setf c1r (- c1r zrr zrr))
  48       (setf c1i (- c1i zri zri))
  49       (multiple-value-bind (var-0 var-1 var-2 var-3)
  50           (zexp c1r c1i s1r s1i)
  51         (declare (ignore var-0 var-1))
  52         (setf s1r var-2)
  53         (setf s1i var-3))
  54       (setf as1 (coerce (realpart (zabs s1r s1i)) 'double-float))
  55       (setf iuf (f2cl-lib:int-add iuf 1))
  56      label10
  57       (setf aa (max as1 as2))
  58       (if (> aa ascle) (go end_label))
  59       (setf s1r zeror)
  60       (setf s1i zeroi)
  61       (setf s2r zeror)
  62       (setf s2i zeroi)
  63       (setf nz 1)
  64       (setf iuf 0)
  65       (go end_label)
  66      end_label
  67       (return (values nil nil s1r s1i s2r s2i nz nil nil iuf)))))
  68
  69 (in-package #:cl-user)
  70 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  71 (eval-when (:load-toplevel :compile-toplevel :execute)
  72   (setf (gethash 'fortran-to-lisp::zs1s2 fortran-to-lisp::*f2cl-function-info*)
  73           (fortran-to-lisp::make-f2cl-finfo
  74            :arg-types '((double-float) (double-float) (double-float)
  75                         (double-float) (double-float) (double-float)
  76                         (fortran-to-lisp::integer4) (double-float)
  77                         (double-float) (fortran-to-lisp::integer4))
  78            :return-values '(nil nil fortran-to-lisp::s1r fortran-to-lisp::s1i
  79                             fortran-to-lisp::s2r fortran-to-lisp::s2i
  80                             fortran-to-lisp::nz nil nil fortran-to-lisp::iuf)
  81            :calls '(fortran-to-lisp::zexp fortran-to-lisp::zlog
  82                     fortran-to-lisp::zabs))))
  83