home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / zbuni.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  7.3 KB  |  199 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (defun zbuni (zr zi fnu kode n yr yi nz nui nlast fnul tol elim alim)
  12.   (declare (type (simple-array double-float (*)) yr yi)
  13.            (type f2cl-lib:integer4 kode n nz nui nlast)
  14.            (type double-float zr zi fnu fnul tol elim alim))
  15.   (prog ((cyr (make-array 2 :element-type 'double-float))
  16.          (cyi (make-array 2 :element-type 'double-float))
  17.          (bry (make-array 3 :element-type 'double-float)) (i 0) (iflag 0)
  18.          (iform 0) (k 0) (nl 0) (nw 0) (ax 0.0) (ay 0.0) (csclr 0.0)
  19.          (cscrr 0.0) (dfnu 0.0) (fnui 0.0) (gnu 0.0) (raz 0.0) (rzi 0.0)
  20.          (rzr 0.0) (sti 0.0) (str 0.0) (s1i 0.0) (s1r 0.0) (s2i 0.0) (s2r 0.0)
  21.          (ascle 0.0) (c1r 0.0) (c1i 0.0) (c1m 0.0))
  22.     (declare (type (simple-array double-float (3)) bry)
  23.              (type (simple-array double-float (2)) cyr cyi)
  24.              (type double-float c1m c1i c1r ascle s2r s2i s1r s1i str sti rzr
  25.               rzi raz gnu fnui dfnu cscrr csclr ay ax)
  26.              (type f2cl-lib:integer4 nw nl k iform iflag i))
  27.     (setf nz 0)
  28.     (setf ax (* (abs zr) 1.7321))
  29.     (setf ay (coerce (abs zi) 'double-float))
  30.     (setf iform 1)
  31.     (if (> ay ax) (setf iform 2))
  32.     (if (= nui 0) (go label60))
  33.     (setf fnui (coerce (the f2cl-lib:integer4 nui) 'double-float))
  34.     (setf dfnu (+ fnu (f2cl-lib:int-sub n 1)))
  35.     (setf gnu (+ dfnu fnui))
  36.     (if (= iform 2) (go label10))
  37.     (multiple-value-bind
  38.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  39.          var-11 var-12)
  40.         (zuni1 zr zi gnu kode 2 cyr cyi nw nlast fnul tol elim alim)
  41.       (declare
  42.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-9 var-10 var-11
  43.         var-12))
  44.       (setf nw var-7)
  45.       (setf nlast var-8))
  46.     (go label20)
  47.    label10
  48.     (multiple-value-bind
  49.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  50.          var-11 var-12)
  51.         (zuni2 zr zi gnu kode 2 cyr cyi nw nlast fnul tol elim alim)
  52.       (declare
  53.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-9 var-10 var-11
  54.         var-12))
  55.       (setf nw var-7)
  56.       (setf nlast var-8))
  57.    label20
  58.     (if (< nw 0) (go label50))
  59.     (if (/= nw 0) (go label90))
  60.     (setf str
  61.             (zabs (f2cl-lib:fref cyr (1) ((1 2)))
  62.              (f2cl-lib:fref cyi (1) ((1 2)))))
  63.     (f2cl-lib:fset (f2cl-lib:fref bry (1) ((1 3)))
  64.                    (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  65.     (f2cl-lib:fset (f2cl-lib:fref bry (2) ((1 3)))
  66.                    (/ 1.0 (f2cl-lib:fref bry (1) ((1 3)))))
  67.     (f2cl-lib:fset (f2cl-lib:fref bry (3) ((1 3)))
  68.                    (f2cl-lib:fref bry (2) ((1 3))))
  69.     (setf iflag 2)
  70.     (setf ascle (f2cl-lib:fref bry (2) ((1 3))))
  71.     (setf csclr 1.0)
  72.     (if (> str (f2cl-lib:fref bry (1) ((1 3)))) (go label21))
  73.     (setf iflag 1)
  74.     (setf ascle (f2cl-lib:fref bry (1) ((1 3))))
  75.     (setf csclr (/ 1.0 tol))
  76.     (go label25)
  77.    label21
  78.     (if (< str (f2cl-lib:fref bry (2) ((1 3)))) (go label25))
  79.     (setf iflag 3)
  80.     (setf ascle (f2cl-lib:fref bry (3) ((1 3))))
  81.     (setf csclr tol)
  82.    label25
  83.     (setf cscrr (/ 1.0 csclr))
  84.     (setf s1r (* (f2cl-lib:fref cyr (2) ((1 2))) csclr))
  85.     (setf s1i (* (f2cl-lib:fref cyi (2) ((1 2))) csclr))
  86.     (setf s2r (* (f2cl-lib:fref cyr (1) ((1 2))) csclr))
  87.     (setf s2i (* (f2cl-lib:fref cyi (1) ((1 2))) csclr))
  88.     (setf raz (/ 1.0 (zabs zr zi)))
  89.     (setf str (* zr raz))
  90.     (setf sti (* (- zi) raz))
  91.     (setf rzr (* (+ str str) raz))
  92.     (setf rzi (* (+ sti sti) raz))
  93.     (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  94.                   ((> i nui) nil)
  95.       (tagbody
  96.         (setf str s2r)
  97.         (setf sti s2i)
  98.         (setf s2r (+ (* (+ dfnu fnui) (- (* rzr str) (* rzi sti))) s1r))
  99.         (setf s2i (+ (* (+ dfnu fnui) (+ (* rzr sti) (* rzi str))) s1i))
  100.         (setf s1r str)
  101.         (setf s1i sti)
  102.         (setf fnui (- fnui 1.0))
  103.         (if (>= iflag 3) (go label30))
  104.         (setf str (* s2r cscrr))
  105.         (setf sti (* s2i cscrr))
  106.         (setf c1r (coerce (abs str) 'double-float))
  107.         (setf c1i (coerce (abs sti) 'double-float))
  108.         (setf c1m (max c1r c1i))
  109.         (if (<= c1m ascle) (go label30))
  110.         (setf iflag (f2cl-lib:int-add iflag 1))
  111.         (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
  112.         (setf s1r (* s1r cscrr))
  113.         (setf s1i (* s1i cscrr))
  114.         (setf s2r str)
  115.         (setf s2i sti)
  116.         (setf csclr (* csclr tol))
  117.         (setf cscrr (/ 1.0 csclr))
  118.         (setf s1r (* s1r csclr))
  119.         (setf s1i (* s1i csclr))
  120.         (setf s2r (* s2r csclr))
  121.         (setf s2i (* s2i csclr))
  122.        label30))
  123.     (f2cl-lib:fset (f2cl-lib:fref yr (n) ((1 n))) (* s2r cscrr))
  124.     (f2cl-lib:fset (f2cl-lib:fref yi (n) ((1 n))) (* s2i cscrr))
  125.     (if (= n 1) (go end_label))
  126.     (setf nl (f2cl-lib:int-sub n 1))
  127.     (setf fnui (coerce (the f2cl-lib:integer4 nl) 'double-float))
  128.     (setf k nl)
  129.     (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  130.                   ((> i nl) nil)
  131.       (tagbody
  132.         (setf str s2r)
  133.         (setf sti s2i)
  134.         (setf s2r (+ (* (+ fnu fnui) (- (* rzr str) (* rzi sti))) s1r))
  135.         (setf s2i (+ (* (+ fnu fnui) (+ (* rzr sti) (* rzi str))) s1i))
  136.         (setf s1r str)
  137.         (setf s1i sti)
  138.         (setf str (* s2r cscrr))
  139.         (setf sti (* s2i cscrr))
  140.         (f2cl-lib:fset (f2cl-lib:fref yr (k) ((1 n))) str)
  141.         (f2cl-lib:fset (f2cl-lib:fref yi (k) ((1 n))) sti)
  142.         (setf fnui (- fnui 1.0))
  143.         (setf k (f2cl-lib:int-sub k 1))
  144.         (if (>= iflag 3) (go label40))
  145.         (setf c1r (coerce (abs str) 'double-float))
  146.         (setf c1i (coerce (abs sti) 'double-float))
  147.         (setf c1m (max c1r c1i))
  148.         (if (<= c1m ascle) (go label40))
  149.         (setf iflag (f2cl-lib:int-add iflag 1))
  150.         (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
  151.         (setf s1r (* s1r cscrr))
  152.         (setf s1i (* s1i cscrr))
  153.         (setf s2r str)
  154.         (setf s2i sti)
  155.         (setf csclr (* csclr tol))
  156.         (setf cscrr (/ 1.0 csclr))
  157.         (setf s1r (* s1r csclr))
  158.         (setf s1i (* s1i csclr))
  159.         (setf s2r (* s2r csclr))
  160.         (setf s2i (* s2i csclr))
  161.        label40))
  162.     (go end_label)
  163.    label50
  164.     (setf nz -1)
  165.     (if (= nw -2) (setf nz -2))
  166.     (go end_label)
  167.    label60
  168.     (if (= iform 2) (go label70))
  169.     (multiple-value-bind
  170.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  171.          var-11 var-12)
  172.         (zuni1 zr zi fnu kode n yr yi nw nlast fnul tol elim alim)
  173.       (declare
  174.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-9 var-10 var-11
  175.         var-12))
  176.       (setf nw var-7)
  177.       (setf nlast var-8))
  178.     (go label80)
  179.    label70
  180.     (multiple-value-bind
  181.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  182.          var-11 var-12)
  183.         (zuni2 zr zi fnu kode n yr yi nw nlast fnul tol elim alim)
  184.       (declare
  185.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-9 var-10 var-11
  186.         var-12))
  187.       (setf nw var-7)
  188.       (setf nlast var-8))
  189.    label80
  190.     (if (< nw 0) (go label50))
  191.     (setf nz nw)
  192.     (go end_label)
  193.    label90
  194.     (setf nlast n)
  195.     (go end_label)
  196.    end_label
  197.     (return (values nil nil nil nil nil nil nil nz nil nlast nil nil nil nil))))
  198.  
  199.