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 / dbesj.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  16.9 KB  |  502 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 t) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((rtwo 1.34839972492648)
  12.       (pdf 0.7853981633974481)
  13.       (rttp 0.7978845608028651)
  14.       (pidt 1.5707963267949)
  15.       (pp (make-array 4 :element-type 'double-float))
  16.       (inlim 150)
  17.       (fnulim (make-array 2 :element-type 'double-float)))
  18.   (declare (type (simple-array double-float (2)) fnulim)
  19.            (type f2cl-lib:integer4 inlim)
  20.            (type (simple-array double-float (4)) pp)
  21.            (type double-float pidt rttp pdf rtwo))
  22.   (f2cl-lib:fset (f2cl-lib:fref pp (1) ((1 4))) 8.72909153935547)
  23.   (f2cl-lib:fset (f2cl-lib:fref pp (2) ((1 4))) 0.26569393226503)
  24.   (f2cl-lib:fset (f2cl-lib:fref pp (3) ((1 4))) 0.124578576865586)
  25.   (f2cl-lib:fset (f2cl-lib:fref pp (4) ((1 4))) 7.701337474303881e-4)
  26.   (f2cl-lib:fset (f2cl-lib:fref fnulim (1) ((1 2))) 100.0)
  27.   (f2cl-lib:fset (f2cl-lib:fref fnulim (2) ((1 2))) 60.0)
  28.   (defun dbesj (x alpha n y nz)
  29.     (declare (type double-float x alpha)
  30.              (type (array double-float (*)) y)
  31.              (type f2cl-lib:integer4 n nz))
  32.     (prog ((temp (make-array 3 :element-type 'double-float))
  33.            (wk (make-array 7 :element-type 'double-float)) (ak 0.0) (akm 0.0)
  34.            (ans 0.0) (ap 0.0) (arg 0.0) (coef 0.0) (dalpha 0.0) (dfn 0.0)
  35.            (dtm 0.0) (earg 0.0) (elim1 0.0) (etx 0.0) (fidal 0.0) (flgjy 0.0)
  36.            (fn 0.0) (fnf 0.0) (fni 0.0) (fnp1 0.0) (fnu 0.0) (gln 0.0)
  37.            (rden 0.0) (relb 0.0) (rtx 0.0) (rzden 0.0) (s 0.0) (sa 0.0)
  38.            (sb 0.0) (sxo2 0.0) (s1 0.0) (s2 0.0) (ta 0.0) (tau 0.0) (tb 0.0)
  39.            (tfn 0.0) (tm 0.0) (tol 0.0) (tolln 0.0) (trx 0.0) (tx 0.0) (t1 0.0)
  40.            (t2 0.0) (xo2 0.0) (xo2l 0.0) (slim 0.0) (rtol 0.0) (i 0) (ialp 0)
  41.            (idalp 0) (iflw 0) (in 0) (is 0) (i1 0) (i2 0) (k 0) (kk 0) (km 0)
  42.            (kt 0) (nn 0) (ns 0) (t_ 0.0))
  43.       (declare
  44.        (type f2cl-lib:integer4 ns nn kt km kk k i2 i1 is in iflw idalp ialp i)
  45.        (type (simple-array double-float (7)) wk)
  46.        (type (simple-array double-float (3)) temp)
  47.        (type double-float t_ rtol slim xo2l xo2 t2 t1 tx trx tolln tol tm tfn
  48.         tb tau ta s2 s1 sxo2 sb sa s rzden rtx relb rden gln fnu fnp1 fni fnf
  49.         fn flgjy fidal etx elim1 earg dtm dfn dalpha coef arg ap ans akm ak))
  50.       (setf nz 0)
  51.       (setf kt 1)
  52.       (setf ns 0)
  53.       (setf ta (f2cl-lib:d1mach 3))
  54.       (setf tol (max ta 1.0000000000000002e-15))
  55.       (setf i1 (f2cl-lib:int-add (f2cl-lib:i1mach 14) 1))
  56.       (setf i2 (f2cl-lib:i1mach 15))
  57.       (setf tb (f2cl-lib:d1mach 5))
  58.       (setf elim1 (* -2.303 (+ (* i2 tb) 3.0)))
  59.       (setf rtol (/ 1.0 tol))
  60.       (setf slim (* (f2cl-lib:d1mach 1) rtol 1000.0))
  61.       (setf tolln (* 2.303 tb i1))
  62.       (setf tolln (min tolln 34.5388))
  63.       (f2cl-lib:arithmetic-if (f2cl-lib:int-sub n 1)
  64.                               (go label720)
  65.                               (go label10)
  66.                               (go label20))
  67.      label10
  68.       (setf kt 2)
  69.      label20
  70.       (setf nn n)
  71.       (f2cl-lib:arithmetic-if x (go label730) (go label30) (go label80))
  72.      label30
  73.       (f2cl-lib:arithmetic-if alpha (go label710) (go label40) (go label50))
  74.      label40
  75.       (f2cl-lib:fset (f2cl-lib:fref y (1) ((1 *))) 1.0)
  76.       (if (= n 1) (go end_label))
  77.       (setf i1 2)
  78.       (go label60)
  79.      label50
  80.       (setf i1 1)
  81.      label60
  82.       (f2cl-lib:fdo (i i1 (f2cl-lib:int-add i 1))
  83.                     ((> i n) nil)
  84.         (tagbody (f2cl-lib:fset (f2cl-lib:fref y (i) ((1 *))) 0.0) label70))
  85.       (go end_label)
  86.      label80
  87.       (if (< alpha 0.0) (go label710))
  88.       (setf ialp (f2cl-lib:int alpha))
  89.       (setf fni
  90.               (coerce
  91.                (the f2cl-lib:integer4
  92.                     (f2cl-lib:int-sub (f2cl-lib:int-add ialp n) 1))
  93.                'double-float))
  94.       (setf fnf (- alpha ialp))
  95.       (setf dfn (+ fni fnf))
  96.       (setf fnu dfn)
  97.       (setf xo2 (* x 0.5))
  98.       (setf sxo2 (* xo2 xo2))
  99.       (if (<= sxo2 (+ fnu 1.0)) (go label90))
  100.       (setf ta (max 20.0 fnu))
  101.       (if (> x ta) (go label120))
  102.       (if (> x 12.0) (go label110))
  103.       (setf xo2l (f2cl-lib:flog xo2))
  104.       (setf ns (f2cl-lib:int-add (f2cl-lib:int (- sxo2 fnu)) 1))
  105.       (go label100)
  106.      label90
  107.       (setf fn fnu)
  108.       (setf fnp1 (+ fn 1.0))
  109.       (setf xo2l (f2cl-lib:flog xo2))
  110.       (setf is kt)
  111.       (if (<= x 0.5) (go label330))
  112.       (setf ns 0)
  113.      label100
  114.       (setf fni (+ fni ns))
  115.       (setf dfn (+ fni fnf))
  116.       (setf fn dfn)
  117.       (setf fnp1 (+ fn 1.0))
  118.       (setf is kt)
  119.       (if (> (f2cl-lib:int-add (f2cl-lib:int-sub n 1) ns) 0) (setf is 3))
  120.       (go label330)
  121.      label110
  122.       (setf ans (max (- 36.0 fnu) 0.0))
  123.       (setf ns (f2cl-lib:int ans))
  124.       (setf fni (+ fni ns))
  125.       (setf dfn (+ fni fnf))
  126.       (setf fn dfn)
  127.       (setf is kt)
  128.       (if (> (f2cl-lib:int-add (f2cl-lib:int-sub n 1) ns) 0) (setf is 3))
  129.       (go label130)
  130.      label120
  131.       (setf rtx (f2cl-lib:fsqrt x))
  132.       (setf tau (* rtwo rtx))
  133.       (setf ta (+ tau (f2cl-lib:fref fnulim (kt) ((1 2)))))
  134.       (if (<= fnu ta) (go label480))
  135.       (setf fn fnu)
  136.       (setf is kt)
  137.      label130
  138.       (setf i1 (f2cl-lib:int (abs (f2cl-lib:int-sub 3 is))))
  139.       (setf i1 (max (the f2cl-lib:integer4 i1) (the f2cl-lib:integer4 1)))
  140.       (setf flgjy 1.0)
  141.       (multiple-value-bind
  142.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
  143.           (dasyjy #'djairy x fn flgjy i1
  144.            (f2cl-lib:array-slice temp double-float (is) ((1 3))) wk iflw)
  145.         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6))
  146.         (setf iflw var-7))
  147.       (if (/= iflw 0) (go label380))
  148.       (f2cl-lib:computed-goto (label320 label450 label620) is)
  149.      label310
  150.       (f2cl-lib:fset (f2cl-lib:fref temp (1) ((1 3)))
  151.                      (f2cl-lib:fref temp (3) ((1 3))))
  152.       (setf kt 1)
  153.      label320
  154.       (setf is 2)
  155.       (setf fni (- fni 1.0))
  156.       (setf dfn (+ fni fnf))
  157.       (setf fn dfn)
  158.       (if (= i1 2) (go label450))
  159.       (go label130)
  160.      label330
  161.       (setf gln (dlngam fnp1))
  162.       (setf arg (- (* fn xo2l) gln))
  163.       (if (< arg (- elim1)) (go label400))
  164.       (setf earg (exp arg))
  165.      label340
  166.       (setf s 1.0)
  167.       (if (< x tol) (go label360))
  168.       (setf ak 3.0)
  169.       (setf t2 1.0)
  170.       (setf t_ 1.0)
  171.       (setf s1 fn)
  172.       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  173.                     ((> k 17) nil)
  174.         (tagbody
  175.           (setf s2 (+ t2 s1))
  176.           (setf t_ (/ (* (- t_) sxo2) s2))
  177.           (setf s (+ s t_))
  178.           (if (< (abs t_) tol) (go label360))
  179.           (setf t2 (+ t2 ak))
  180.           (setf ak (+ ak 2.0))
  181.           (setf s1 (+ s1 fn))
  182.          label350))
  183.      label360
  184.       (f2cl-lib:fset (f2cl-lib:fref temp (is) ((1 3))) (* s earg))
  185.       (f2cl-lib:computed-goto (label370 label450 label610) is)
  186.      label370
  187.       (setf earg (/ (* earg fn) xo2))
  188.       (setf fni (- fni 1.0))
  189.       (setf dfn (+ fni fnf))
  190.       (setf fn dfn)
  191.       (setf is 2)
  192.       (go label340)
  193.      label380
  194.       (f2cl-lib:fset (f2cl-lib:fref y (nn) ((1 *))) 0.0)
  195.       (setf nn (f2cl-lib:int-sub nn 1))
  196.       (setf fni (- fni 1.0))
  197.       (setf dfn (+ fni fnf))
  198.       (setf fn dfn)
  199.       (f2cl-lib:arithmetic-if (f2cl-lib:int-sub nn 1)
  200.                               (go label440)
  201.                               (go label390)
  202.                               (go label130))
  203.      label390
  204.       (setf kt 2)
  205.       (setf is 2)
  206.       (go label130)
  207.      label400
  208.       (f2cl-lib:fset (f2cl-lib:fref y (nn) ((1 *))) 0.0)
  209.       (setf nn (f2cl-lib:int-sub nn 1))
  210.       (setf fnp1 fn)
  211.       (setf fni (- fni 1.0))
  212.       (setf dfn (+ fni fnf))
  213.       (setf fn dfn)
  214.       (f2cl-lib:arithmetic-if (f2cl-lib:int-sub nn 1)
  215.                               (go label440)
  216.                               (go label410)
  217.                               (go label420))
  218.      label410
  219.       (setf kt 2)
  220.       (setf is 2)
  221.      label420
  222.       (if (<= sxo2 fnp1) (go label430))
  223.       (go label130)
  224.      label430
  225.       (setf arg (+ (- arg xo2l) (f2cl-lib:flog fnp1)))
  226.       (if (< arg (- elim1)) (go label400))
  227.       (go label330)
  228.      label440
  229.       (setf nz (f2cl-lib:int-sub n nn))
  230.       (go end_label)
  231.      label450
  232.       (if (/= ns 0) (go label451))
  233.       (setf nz (f2cl-lib:int-sub n nn))
  234.       (if (= kt 2) (go label470))
  235.       (f2cl-lib:fset (f2cl-lib:fref y (nn) ((1 *)))
  236.                      (f2cl-lib:fref temp (1) ((1 3))))
  237.       (f2cl-lib:fset (f2cl-lib:fref y ((f2cl-lib:int-sub nn 1)) ((1 *)))
  238.                      (f2cl-lib:fref temp (2) ((1 3))))
  239.       (if (= nn 2) (go end_label))
  240.      label451
  241.       (setf trx (/ 2.0 x))
  242.       (setf dtm fni)
  243.       (setf tm (* (+ dtm fnf) trx))
  244.       (setf ak 1.0)
  245.       (setf ta (f2cl-lib:fref temp (1) ((1 3))))
  246.       (setf tb (f2cl-lib:fref temp (2) ((1 3))))
  247.       (if (> (abs ta) slim) (go label455))
  248.       (setf ta (* ta rtol))
  249.       (setf tb (* tb rtol))
  250.       (setf ak tol)
  251.      label455
  252.       (setf kk 2)
  253.       (setf in (f2cl-lib:int-sub ns 1))
  254.       (if (= in 0) (go label690))
  255.       (if (/= ns 0) (go label670))
  256.       (setf k (f2cl-lib:int-sub nn 2))
  257.       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 1))
  258.                     ((> i nn) nil)
  259.         (tagbody
  260.           (setf s tb)
  261.           (setf tb (- (* tm tb) ta))
  262.           (setf ta s)
  263.           (f2cl-lib:fset (f2cl-lib:fref y (k) ((1 *))) (* tb ak))
  264.           (setf dtm (- dtm 1.0))
  265.           (setf tm (* (+ dtm fnf) trx))
  266.           (setf k (f2cl-lib:int-sub k 1))
  267.          label460))
  268.       (go end_label)
  269.      label470
  270.       (f2cl-lib:fset (f2cl-lib:fref y (1) ((1 *)))
  271.                      (f2cl-lib:fref temp (2) ((1 3))))
  272.       (go end_label)
  273.      label480
  274.       (setf in (f2cl-lib:int (+ (- alpha tau) 2.0)))
  275.       (if (<= in 0) (go label490))
  276.       (setf idalp (f2cl-lib:int-sub ialp in 1))
  277.       (setf kt 1)
  278.       (go label500)
  279.      label490
  280.       (setf idalp ialp)
  281.       (setf in 0)
  282.      label500
  283.       (setf is kt)
  284.       (setf fidal (coerce (the f2cl-lib:integer4 idalp) 'double-float))
  285.       (setf dalpha (+ fidal fnf))
  286.       (setf arg (- x (* pidt dalpha) pdf))
  287.       (setf sa (sin arg))
  288.       (setf sb (cos arg))
  289.       (setf coef (/ rttp rtx))
  290.       (setf etx (* 8.0 x))
  291.      label510
  292.       (setf dtm (+ fidal fidal))
  293.       (setf dtm (* dtm dtm))
  294.       (setf tm 0.0)
  295.       (if (and (= fidal 0.0) (< (abs fnf) tol)) (go label520))
  296.       (setf tm (* 4.0 fnf (+ fidal fidal fnf)))
  297.      label520
  298.       (setf trx (- dtm 1.0))
  299.       (setf t2 (/ (+ trx tm) etx))
  300.       (setf s2 t2)
  301.       (setf relb (* tol (abs t2)))
  302.       (setf t1 etx)
  303.       (setf s1 1.0)
  304.       (setf fn 1.0)
  305.       (setf ak 8.0)
  306.       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  307.                     ((> k 13) nil)
  308.         (tagbody
  309.           (setf t1 (+ t1 etx))
  310.           (setf fn (+ fn ak))
  311.           (setf trx (- dtm fn))
  312.           (setf ap (+ trx tm))
  313.           (setf t2 (/ (* (- t2) ap) t1))
  314.           (setf s1 (+ s1 t2))
  315.           (setf t1 (+ t1 etx))
  316.           (setf ak (+ ak 8.0))
  317.           (setf fn (+ fn ak))
  318.           (setf trx (- dtm fn))
  319.           (setf ap (+ trx tm))
  320.           (setf t2 (/ (* t2 ap) t1))
  321.           (setf s2 (+ s2 t2))
  322.           (if (<= (abs t2) relb) (go label540))
  323.           (setf ak (+ ak 8.0))
  324.          label530))
  325.      label540
  326.       (f2cl-lib:fset (f2cl-lib:fref temp (is) ((1 3)))
  327.                      (* coef (- (* s1 sb) (* s2 sa))))
  328.       (if (= is 2) (go label560))
  329.       (setf fidal (+ fidal 1.0))
  330.       (setf dalpha (+ fidal fnf))
  331.       (setf is 2)
  332.       (setf tb sa)
  333.       (setf sa (- sb))
  334.       (setf sb tb)
  335.       (go label510)
  336.      label560
  337.       (if (= kt 2) (go label470))
  338.       (setf s1 (f2cl-lib:fref temp (1) ((1 3))))
  339.       (setf s2 (f2cl-lib:fref temp (2) ((1 3))))
  340.       (setf tx (/ 2.0 x))
  341.       (setf tm (* dalpha tx))
  342.       (if (= in 0) (go label580))
  343.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  344.                     ((> i in) nil)
  345.         (tagbody
  346.           (setf s s2)
  347.           (setf s2 (- (* tm s2) s1))
  348.           (setf tm (+ tm tx))
  349.           (setf s1 s)
  350.          label570))
  351.       (if (= nn 1) (go label600))
  352.       (setf s s2)
  353.       (setf s2 (- (* tm s2) s1))
  354.       (setf tm (+ tm tx))
  355.       (setf s1 s)
  356.      label580
  357.       (f2cl-lib:fset (f2cl-lib:fref y (1) ((1 *))) s1)
  358.       (f2cl-lib:fset (f2cl-lib:fref y (2) ((1 *))) s2)
  359.       (if (= nn 2) (go end_label))
  360.       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 1))
  361.                     ((> i nn) nil)
  362.         (tagbody
  363.           (f2cl-lib:fset (f2cl-lib:fref y (i) ((1 *)))
  364.                          (-
  365.                           (* tm
  366.                              (f2cl-lib:fref y
  367.                                             ((f2cl-lib:int-sub i 1))
  368.                                             ((1 *))))
  369.                           (f2cl-lib:fref y ((f2cl-lib:int-sub i 2)) ((1 *)))))
  370.           (setf tm (+ tm tx))
  371.          label590))
  372.       (go end_label)
  373.      label600
  374.       (f2cl-lib:fset (f2cl-lib:fref y (1) ((1 *))) s2)
  375.       (go end_label)
  376.      label610
  377.       (setf akm (max (- 3.0 fn) 0.0))
  378.       (setf km (f2cl-lib:int akm))
  379.       (setf tfn (+ fn km))
  380.       (setf ta
  381.               (/ (+ (- (+ gln tfn) 0.9189385332) (/ -0.0833333333 tfn))
  382.                  (+ tfn 0.5)))
  383.       (setf ta (- xo2l ta))
  384.       (setf tb (/ (- (+ 1.0 (/ (* -1 1.5) tfn))) tfn))
  385.       (setf akm
  386.               (+ (/ tolln (- (f2cl-lib:fsqrt (- (* ta ta) (* tolln tb))) ta))
  387.                  1.5))
  388.       (setf in (f2cl-lib:int-add km (f2cl-lib:int akm)))
  389.       (go label660)
  390.      label620
  391.       (setf gln
  392.               (+ (f2cl-lib:fref wk (3) ((1 7)))
  393.                  (f2cl-lib:fref wk (2) ((1 7)))))
  394.       (if (> (f2cl-lib:fref wk (6) ((1 7))) 30.0) (go label640))
  395.       (setf rden
  396.               (+
  397.                (*
  398.                 (+
  399.                  (* (f2cl-lib:fref pp (4) ((1 4)))
  400.                     (f2cl-lib:fref wk (6) ((1 7))))
  401.                  (f2cl-lib:fref pp (3) ((1 4))))
  402.                 (f2cl-lib:fref wk (6) ((1 7))))
  403.                1.0))
  404.       (setf rzden
  405.               (+ (f2cl-lib:fref pp (1) ((1 4)))
  406.                  (* (f2cl-lib:fref pp (2) ((1 4)))
  407.                     (f2cl-lib:fref wk (6) ((1 7))))))
  408.       (setf ta (/ rzden rden))
  409.       (if (< (f2cl-lib:fref wk (1) ((1 7))) 0.1) (go label630))
  410.       (setf tb (/ gln (f2cl-lib:fref wk (5) ((1 7)))))
  411.       (go label650)
  412.      label630
  413.       (setf tb
  414.               (/
  415.                (+ 1.259921049
  416.                   (*
  417.                    (+ 0.167989473
  418.                       (* 0.0887944358 (f2cl-lib:fref wk (1) ((1 7)))))
  419.                    (f2cl-lib:fref wk (1) ((1 7)))))
  420.                (f2cl-lib:fref wk (7) ((1 7)))))
  421.       (go label650)
  422.      label640
  423.       (setf ta (/ (* 0.5 tolln) (f2cl-lib:fref wk (4) ((1 7)))))
  424.       (setf ta
  425.               (* (+ (* (- (* 0.049382716 ta) 0.1111111111) ta) 0.6666666667)
  426.                  ta
  427.                  (f2cl-lib:fref wk (6) ((1 7)))))
  428.       (if (< (f2cl-lib:fref wk (1) ((1 7))) 0.1) (go label630))
  429.       (setf tb (/ gln (f2cl-lib:fref wk (5) ((1 7)))))
  430.      label650
  431.       (setf in (f2cl-lib:int (+ (/ ta tb) 1.5)))
  432.       (if (> in inlim) (go label310))
  433.      label660
  434.       (setf dtm (+ fni in))
  435.       (setf trx (/ 2.0 x))
  436.       (setf tm (* (+ dtm fnf) trx))
  437.       (setf ta 0.0)
  438.       (setf tb tol)
  439.       (setf kk 1)
  440.       (setf ak 1.0)
  441.      label670
  442.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  443.                     ((> i in) nil)
  444.         (tagbody
  445.           (setf s tb)
  446.           (setf tb (- (* tm tb) ta))
  447.           (setf ta s)
  448.           (setf dtm (- dtm 1.0))
  449.           (setf tm (* (+ dtm fnf) trx))
  450.          label680))
  451.       (if (/= kk 1) (go label690))
  452.       (setf s (f2cl-lib:fref temp (3) ((1 3))))
  453.       (setf sa (/ ta tb))
  454.       (setf ta s)
  455.       (setf tb s)
  456.       (if (> (abs s) slim) (go label685))
  457.       (setf ta (* ta rtol))
  458.       (setf tb (* tb rtol))
  459.       (setf ak tol)
  460.      label685
  461.       (setf ta (* ta sa))
  462.       (setf kk 2)
  463.       (setf in ns)
  464.       (if (/= ns 0) (go label670))
  465.      label690
  466.       (f2cl-lib:fset (f2cl-lib:fref y (nn) ((1 *))) (* tb ak))
  467.       (setf nz (f2cl-lib:int-sub n nn))
  468.       (if (= nn 1) (go end_label))
  469.       (setf k (f2cl-lib:int-sub nn 1))
  470.       (setf s tb)
  471.       (setf tb (- (* tm tb) ta))
  472.       (setf ta s)
  473.       (f2cl-lib:fset (f2cl-lib:fref y (k) ((1 *))) (* tb ak))
  474.       (if (= nn 2) (go end_label))
  475.       (setf dtm (- dtm 1.0))
  476.       (setf tm (* (+ dtm fnf) trx))
  477.       (setf k (f2cl-lib:int-sub nn 2))
  478.       (f2cl-lib:fdo (i 3 (f2cl-lib:int-add i 1))
  479.                     ((> i nn) nil)
  480.         (tagbody
  481.           (setf s tb)
  482.           (setf tb (- (* tm tb) ta))
  483.           (setf ta s)
  484.           (f2cl-lib:fset (f2cl-lib:fref y (k) ((1 *))) (* tb ak))
  485.           (setf dtm (- dtm 1.0))
  486.           (setf tm (* (+ dtm fnf) trx))
  487.           (setf k (f2cl-lib:int-sub k 1))
  488.          label700))
  489.       (go end_label)
  490.      label710
  491.       (xermsg "SLATEC" "DBESJ" "ORDER, ALPHA, LESS THAN ZERO." 2 1)
  492.       (go end_label)
  493.      label720
  494.       (xermsg "SLATEC" "DBESJ" "N LESS THAN ONE." 2 1)
  495.       (go end_label)
  496.      label730
  497.       (xermsg "SLATEC" "DBESJ" "X LESS THAN ZERO." 2 1)
  498.       (go end_label)
  499.      end_label
  500.       (return (values nil nil nil nil nz)))))
  501.  
  502.