src/numerical/slatec/zbuni.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 (defun zbuni (zr zi fnu kode n yr yi nz nui nlast fnul tol elim alim)
  21   (declare (type (simple-array double-float (*)) yi yr)
  22            (type (f2cl-lib:integer4) nlast nui nz n kode)
  23            (type (double-float) alim elim tol fnul fnu zi zr))
  24   (prog ((cyr (make-array 2 :element-type 'double-float))
  25          (cyi (make-array 2 :element-type 'double-float))
  26          (bry (make-array 3 :element-type 'double-float)) (i 0) (iflag 0)
  27          (iform 0) (k 0) (nl 0) (nw 0) (ax 0.0) (ay 0.0) (csclr 0.0)
  28          (cscrr 0.0) (dfnu 0.0) (fnui 0.0) (gnu 0.0) (raz 0.0) (rzi 0.0)
  29          (rzr 0.0) (sti 0.0) (str 0.0) (s1i 0.0) (s1r 0.0) (s2i 0.0) (s2r 0.0)
  30          (ascle 0.0) (c1r 0.0) (c1i 0.0) (c1m 0.0))
  31     (declare (type (simple-array double-float (3)) bry)
  32              (type (simple-array double-float (2)) cyr cyi)
  33              (type (double-float) c1m c1i c1r ascle s2r s2i s1r s1i str sti rzr
  34                                   rzi raz gnu fnui dfnu cscrr csclr ay ax)
  35              (type (f2cl-lib:integer4) nw nl k iform iflag i))
  36     (setf nz 0)
  37     (setf ax (* (abs zr) 1.7321))
  38     (setf ay (abs zi))
  39     (setf iform 1)
  40     (if (> ay ax) (setf iform 2))
  41     (if (= nui 0) (go label60))
  42     (setf fnui (coerce (the f2cl-lib:integer4 nui) 'double-float))
  43     (setf dfnu (+ fnu (f2cl-lib:int-sub n 1)))
  44     (setf gnu (+ dfnu fnui))
  45     (if (= iform 2) (go label10))
  46     (multiple-value-bind
  47           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  48            var-11 var-12)
  49         (zuni1 zr zi gnu kode 2 cyr cyi nw nlast fnul tol elim alim)
  50       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-9 var-10
  51                        var-11 var-12))
  52       (setf nw var-7)
  53       (setf nlast var-8))
  54     (go label20)
  55    label10
  56     (multiple-value-bind
  57           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  58            var-11 var-12)
  59         (zuni2 zr zi gnu kode 2 cyr cyi nw nlast fnul tol elim alim)
  60       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-9 var-10
  61                        var-11 var-12))
  62       (setf nw var-7)
  63       (setf nlast var-8))
  64    label20
  65     (if (< nw 0) (go label50))
  66     (if (/= nw 0) (go label90))
  67     (setf str
  68             (coerce
  69              (realpart
  70               (zabs (f2cl-lib:fref cyr (1) ((1 2)))
  71                (f2cl-lib:fref cyi (1) ((1 2)))))
  72              'double-float))
  73     (setf (f2cl-lib:fref bry (1) ((1 3)))
  74             (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  75     (setf (f2cl-lib:fref bry (2) ((1 3)))
  76             (/ 1.0 (f2cl-lib:fref bry (1) ((1 3)))))
  77     (setf (f2cl-lib:fref bry (3) ((1 3))) (f2cl-lib:fref bry (2) ((1 3))))
  78     (setf iflag 2)
  79     (setf ascle (f2cl-lib:fref bry (2) ((1 3))))
  80     (setf csclr 1.0)
  81     (if (> str (f2cl-lib:fref bry (1) ((1 3)))) (go label21))
  82     (setf iflag 1)
  83     (setf ascle (f2cl-lib:fref bry (1) ((1 3))))
  84     (setf csclr (/ 1.0 tol))
  85     (go label25)
  86    label21
  87     (if (< str (f2cl-lib:fref bry (2) ((1 3)))) (go label25))
  88     (setf iflag 3)
  89     (setf ascle (f2cl-lib:fref bry (3) ((1 3))))
  90     (setf csclr tol)
  91    label25
  92     (setf cscrr (/ 1.0 csclr))
  93     (setf s1r (* (f2cl-lib:fref cyr (2) ((1 2))) csclr))
  94     (setf s1i (* (f2cl-lib:fref cyi (2) ((1 2))) csclr))
  95     (setf s2r (* (f2cl-lib:fref cyr (1) ((1 2))) csclr))
  96     (setf s2i (* (f2cl-lib:fref cyi (1) ((1 2))) csclr))
  97     (setf raz (coerce (realpart (/ 1.0 (zabs zr zi))) 'double-float))
  98     (setf str (* zr raz))
  99     (setf sti (* (- zi) raz))
 100     (setf rzr (* (+ str str) raz))
 101     (setf rzi (* (+ sti sti) raz))
 102     (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 103                   ((> i nui) nil)
 104       (tagbody
 105         (setf str s2r)
 106         (setf sti s2i)
 107         (setf s2r (+ (* (+ dfnu fnui) (- (* rzr str) (* rzi sti))) s1r))
 108         (setf s2i (+ (* (+ dfnu fnui) (+ (* rzr sti) (* rzi str))) s1i))
 109         (setf s1r str)
 110         (setf s1i sti)
 111         (setf fnui (- fnui 1.0))
 112         (if (>= iflag 3) (go label30))
 113         (setf str (* s2r cscrr))
 114         (setf sti (* s2i cscrr))
 115         (setf c1r (abs str))
 116         (setf c1i (abs sti))
 117         (setf c1m (max c1r c1i))
 118         (if (<= c1m ascle) (go label30))
 119         (setf iflag (f2cl-lib:int-add iflag 1))
 120         (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
 121         (setf s1r (* s1r cscrr))
 122         (setf s1i (* s1i cscrr))
 123         (setf s2r str)
 124         (setf s2i sti)
 125         (setf csclr (* csclr tol))
 126         (setf cscrr (/ 1.0 csclr))
 127         (setf s1r (* s1r csclr))
 128         (setf s1i (* s1i csclr))
 129         (setf s2r (* s2r csclr))
 130         (setf s2i (* s2i csclr))
 131        label30))
 132     (setf (f2cl-lib:fref yr (n) ((1 n))) (* s2r cscrr))
 133     (setf (f2cl-lib:fref yi (n) ((1 n))) (* s2i cscrr))
 134     (if (= n 1) (go end_label))
 135     (setf nl (f2cl-lib:int-sub n 1))
 136     (setf fnui (coerce (the f2cl-lib:integer4 nl) 'double-float))
 137     (setf k nl)
 138     (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 139                   ((> i nl) nil)
 140       (tagbody
 141         (setf str s2r)
 142         (setf sti s2i)
 143         (setf s2r (+ (* (+ fnu fnui) (- (* rzr str) (* rzi sti))) s1r))
 144         (setf s2i (+ (* (+ fnu fnui) (+ (* rzr sti) (* rzi str))) s1i))
 145         (setf s1r str)
 146         (setf s1i sti)
 147         (setf str (* s2r cscrr))
 148         (setf sti (* s2i cscrr))
 149         (setf (f2cl-lib:fref yr (k) ((1 n))) str)
 150         (setf (f2cl-lib:fref yi (k) ((1 n))) sti)
 151         (setf fnui (- fnui 1.0))
 152         (setf k (f2cl-lib:int-sub k 1))
 153         (if (>= iflag 3) (go label40))
 154         (setf c1r (abs str))
 155         (setf c1i (abs sti))
 156         (setf c1m (max c1r c1i))
 157         (if (<= c1m ascle) (go label40))
 158         (setf iflag (f2cl-lib:int-add iflag 1))
 159         (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
 160         (setf s1r (* s1r cscrr))
 161         (setf s1i (* s1i cscrr))
 162         (setf s2r str)
 163         (setf s2i sti)
 164         (setf csclr (* csclr tol))
 165         (setf cscrr (/ 1.0 csclr))
 166         (setf s1r (* s1r csclr))
 167         (setf s1i (* s1i csclr))
 168         (setf s2r (* s2r csclr))
 169         (setf s2i (* s2i csclr))
 170        label40))
 171     (go end_label)
 172    label50
 173     (setf nz -1)
 174     (if (= nw -2) (setf nz -2))
 175     (go end_label)
 176    label60
 177     (if (= iform 2) (go label70))
 178     (multiple-value-bind
 179           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 180            var-11 var-12)
 181         (zuni1 zr zi fnu kode n yr yi nw nlast fnul tol elim alim)
 182       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-9 var-10
 183                        var-11 var-12))
 184       (setf nw var-7)
 185       (setf nlast var-8))
 186     (go label80)
 187    label70
 188     (multiple-value-bind
 189           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 190            var-11 var-12)
 191         (zuni2 zr zi fnu kode n yr yi nw nlast fnul tol elim alim)
 192       (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-9 var-10
 193                        var-11 var-12))
 194       (setf nw var-7)
 195       (setf nlast var-8))
 196    label80
 197     (if (< nw 0) (go label50))
 198     (setf nz nw)
 199     (go end_label)
 200    label90
 201     (setf nlast n)
 202     (go end_label)
 203    end_label
 204     (return (values nil nil nil nil nil nil nil nz nil nlast nil nil nil nil))))
 205
 206 (in-package #:cl-user)
 207 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 208 (eval-when (:load-toplevel :compile-toplevel :execute)
 209   (setf (gethash 'fortran-to-lisp::zbuni fortran-to-lisp::*f2cl-function-info*)
 210           (fortran-to-lisp::make-f2cl-finfo
 211            :arg-types '((double-float) (double-float) (double-float)
 212                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 213                         (simple-array double-float (*))
 214                         (simple-array double-float (*))
 215                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 216                         (fortran-to-lisp::integer4) (double-float)
 217                         (double-float) (double-float) (double-float))
 218            :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::nz nil
 219                             fortran-to-lisp::nlast nil nil nil nil)
 220            :calls '(fortran-to-lisp::d1mach fortran-to-lisp::zabs
 221                     fortran-to-lisp::zuni2 fortran-to-lisp::zuni1))))
 222