src/numerical/slatec/zbinu.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 zbinu (zr zi fnu kode n cyr cyi nz rl fnul tol elim alim)
  23     (declare (type (simple-array double-float (*)) cyi cyr)
  24              (type (f2cl-lib:integer4) nz n kode)
  25              (type (double-float) alim elim tol fnul rl fnu zi zr))
  26     (prog ((cwr (make-array 2 :element-type 'double-float))
  27            (cwi (make-array 2 :element-type 'double-float)) (i 0) (inw 0)
  28            (nlast 0) (nn 0) (nui 0) (nw 0) (az 0.0) (dfnu 0.0))
  29       (declare (type (simple-array double-float (2)) cwr cwi)
  30                (type (double-float) dfnu az)
  31                (type (f2cl-lib:integer4) nw nui nn nlast inw i))
  32       (setf nz 0)
  33       (setf az (coerce (realpart (zabs zr zi)) 'double-float))
  34       (setf nn n)
  35       (setf dfnu (+ fnu (f2cl-lib:int-sub n 1)))
  36       (if (<= az 2.0) (go label10))
  37       (if (> (* az az 0.25) (+ dfnu 1.0)) (go label20))
  38      label10
  39       (multiple-value-bind
  40             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  41              var-10)
  42           (zseri zr zi fnu kode nn cyr cyi nw tol elim alim)
  43         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  44                          var-10))
  45         (setf nw var-7))
  46       (setf inw (abs nw))
  47       (setf nz (f2cl-lib:int-add nz inw))
  48       (setf nn (f2cl-lib:int-sub nn inw))
  49       (if (= nn 0) (go end_label))
  50       (if (>= nw 0) (go label120))
  51       (setf dfnu (+ fnu (f2cl-lib:int-sub nn 1)))
  52      label20
  53       (if (< az rl) (go label40))
  54       (if (<= dfnu 1.0) (go label30))
  55       (if (< (+ az az) (* dfnu dfnu)) (go label50))
  56      label30
  57       (multiple-value-bind
  58             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  59              var-11)
  60           (zasyi zr zi fnu kode nn cyr cyi nw rl tol elim alim)
  61         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
  62                          var-10 var-11))
  63         (setf nw var-7))
  64       (if (< nw 0) (go label130))
  65       (go label120)
  66      label40
  67       (if (<= dfnu 1.0) (go label70))
  68      label50
  69       (multiple-value-bind
  70             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  71              var-11)
  72           (zuoik zr zi fnu kode 1 nn cyr cyi nw tol elim alim)
  73         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9
  74                          var-10 var-11))
  75         (setf nw var-8))
  76       (if (< nw 0) (go label130))
  77       (setf nz (f2cl-lib:int-add nz nw))
  78       (setf nn (f2cl-lib:int-sub nn nw))
  79       (if (= nn 0) (go end_label))
  80       (setf dfnu (+ fnu (f2cl-lib:int-sub nn 1)))
  81       (if (> dfnu fnul) (go label110))
  82       (if (> az fnul) (go label110))
  83      label60
  84       (if (> az rl) (go label80))
  85      label70
  86       (multiple-value-bind
  87             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8)
  88           (zmlri zr zi fnu kode nn cyr cyi nw tol)
  89         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8))
  90         (setf nw var-7))
  91       (if (< nw 0) (go label130))
  92       (go label120)
  93      label80
  94       (multiple-value-bind
  95             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  96              var-11)
  97           (zuoik zr zi fnu kode 2 2 cwr cwi nw tol elim alim)
  98         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-9
  99                          var-10 var-11))
 100         (setf nw var-8))
 101       (if (>= nw 0) (go label100))
 102       (setf nz nn)
 103       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 104                     ((> i nn) nil)
 105         (tagbody
 106           (setf (f2cl-lib:fref cyr (i) ((1 n))) zeror)
 107           (setf (f2cl-lib:fref cyi (i) ((1 n))) zeroi)
 108          label90))
 109       (go end_label)
 110      label100
 111       (if (> nw 0) (go label130))
 112       (multiple-value-bind
 113             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 114              var-11 var-12)
 115           (zwrsk zr zi fnu kode nn cyr cyi nw cwr cwi tol elim alim)
 116         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9
 117                          var-10 var-11 var-12))
 118         (setf nw var-7))
 119       (if (< nw 0) (go label130))
 120       (go label120)
 121      label110
 122       (setf nui (f2cl-lib:int (+ (- fnul dfnu) 1)))
 123       (setf nui (max (the f2cl-lib:integer4 nui) (the f2cl-lib:integer4 0)))
 124       (multiple-value-bind
 125             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 126              var-11 var-12 var-13)
 127           (zbuni zr zi fnu kode nn cyr cyi nw nui nlast fnul tol elim alim)
 128         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-10
 129                          var-11 var-12 var-13))
 130         (setf nw var-7)
 131         (setf nlast var-9))
 132       (if (< nw 0) (go label130))
 133       (setf nz (f2cl-lib:int-add nz nw))
 134       (if (= nlast 0) (go label120))
 135       (setf nn nlast)
 136       (go label60)
 137      label120
 138       (go end_label)
 139      label130
 140       (setf nz -1)
 141       (if (= nw -2) (setf nz -2))
 142       (go end_label)
 143      end_label
 144       (return (values nil nil nil nil nil nil nil nz nil nil nil nil nil)))))
 145
 146 (in-package #:cl-user)
 147 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 148 (eval-when (:load-toplevel :compile-toplevel :execute)
 149   (setf (gethash 'fortran-to-lisp::zbinu fortran-to-lisp::*f2cl-function-info*)
 150           (fortran-to-lisp::make-f2cl-finfo
 151            :arg-types '((double-float) (double-float) (double-float)
 152                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 153                         (simple-array double-float (*))
 154                         (simple-array double-float (*))
 155                         (fortran-to-lisp::integer4) (double-float)
 156                         (double-float) (double-float) (double-float)
 157                         (double-float))
 158            :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::nz nil
 159                             nil nil nil nil)
 160            :calls '(fortran-to-lisp::zbuni fortran-to-lisp::zwrsk
 161                     fortran-to-lisp::zmlri fortran-to-lisp::zuoik
 162                     fortran-to-lisp::zasyi fortran-to-lisp::zseri
 163                     fortran-to-lisp::zabs))))
 164