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 / dgamln.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  11.6 KB  |  213 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. (let ((gln (make-array 100 :element-type 'double-float))
  12.       (cf (make-array 22 :element-type 'double-float))
  13.       (con 1.8378770664093456))
  14.   (declare (type double-float con)
  15.            (type (simple-array double-float (22)) cf)
  16.            (type (simple-array double-float (100)) gln))
  17.   (f2cl-lib:fset (f2cl-lib:fref gln (1) ((1 100))) 0.0)
  18.   (f2cl-lib:fset (f2cl-lib:fref gln (2) ((1 100))) 0.0)
  19.   (f2cl-lib:fset (f2cl-lib:fref gln (3) ((1 100))) 0.6931471805599454)
  20.   (f2cl-lib:fset (f2cl-lib:fref gln (4) ((1 100))) 1.791759469228055)
  21.   (f2cl-lib:fset (f2cl-lib:fref gln (5) ((1 100))) 3.1780538303479458)
  22.   (f2cl-lib:fset (f2cl-lib:fref gln (6) ((1 100))) 4.787491742782046)
  23.   (f2cl-lib:fset (f2cl-lib:fref gln (7) ((1 100))) 6.579251212010101)
  24.   (f2cl-lib:fset (f2cl-lib:fref gln (8) ((1 100))) 8.525161361065415)
  25.   (f2cl-lib:fset (f2cl-lib:fref gln (9) ((1 100))) 10.60460290274525)
  26.   (f2cl-lib:fset (f2cl-lib:fref gln (10) ((1 100))) 12.801827480081469)
  27.   (f2cl-lib:fset (f2cl-lib:fref gln (11) ((1 100))) 15.104412573075516)
  28.   (f2cl-lib:fset (f2cl-lib:fref gln (12) ((1 100))) 17.502307845873887)
  29.   (f2cl-lib:fset (f2cl-lib:fref gln (13) ((1 100))) 19.98721449566189)
  30.   (f2cl-lib:fset (f2cl-lib:fref gln (14) ((1 100))) 22.552163853123425)
  31.   (f2cl-lib:fset (f2cl-lib:fref gln (15) ((1 100))) 25.191221182738683)
  32.   (f2cl-lib:fset (f2cl-lib:fref gln (16) ((1 100))) 27.89927138384089)
  33.   (f2cl-lib:fset (f2cl-lib:fref gln (17) ((1 100))) 30.671860106080672)
  34.   (f2cl-lib:fset (f2cl-lib:fref gln (18) ((1 100))) 33.50507345013689)
  35.   (f2cl-lib:fset (f2cl-lib:fref gln (19) ((1 100))) 36.39544520803305)
  36.   (f2cl-lib:fset (f2cl-lib:fref gln (20) ((1 100))) 39.339884187199495)
  37.   (f2cl-lib:fset (f2cl-lib:fref gln (21) ((1 100))) 42.335616460753485)
  38.   (f2cl-lib:fset (f2cl-lib:fref gln (22) ((1 100))) 45.38013889847691)
  39.   (f2cl-lib:fset (f2cl-lib:fref gln (23) ((1 100))) 48.47118135183522)
  40.   (f2cl-lib:fset (f2cl-lib:fref gln (24) ((1 100))) 51.60667556776438)
  41.   (f2cl-lib:fset (f2cl-lib:fref gln (25) ((1 100))) 54.78472939811232)
  42.   (f2cl-lib:fset (f2cl-lib:fref gln (26) ((1 100))) 58.003605222980525)
  43.   (f2cl-lib:fset (f2cl-lib:fref gln (27) ((1 100))) 61.261701761002)
  44.   (f2cl-lib:fset (f2cl-lib:fref gln (28) ((1 100))) 64.55753862700634)
  45.   (f2cl-lib:fset (f2cl-lib:fref gln (29) ((1 100))) 67.88974313718154)
  46.   (f2cl-lib:fset (f2cl-lib:fref gln (30) ((1 100))) 71.25703896716801)
  47.   (f2cl-lib:fset (f2cl-lib:fref gln (31) ((1 100))) 74.65823634883017)
  48.   (f2cl-lib:fset (f2cl-lib:fref gln (32) ((1 100))) 78.0922235533153)
  49.   (f2cl-lib:fset (f2cl-lib:fref gln (33) ((1 100))) 81.55795945611503)
  50.   (f2cl-lib:fset (f2cl-lib:fref gln (34) ((1 100))) 85.05446701758152)
  51.   (f2cl-lib:fset (f2cl-lib:fref gln (35) ((1 100))) 88.58082754219767)
  52.   (f2cl-lib:fset (f2cl-lib:fref gln (36) ((1 100))) 92.1361756036871)
  53.   (f2cl-lib:fset (f2cl-lib:fref gln (37) ((1 100))) 95.7196945421432)
  54.   (f2cl-lib:fset (f2cl-lib:fref gln (38) ((1 100))) 99.33061245478743)
  55.   (f2cl-lib:fset (f2cl-lib:fref gln (39) ((1 100))) 102.96819861451381)
  56.   (f2cl-lib:fset (f2cl-lib:fref gln (40) ((1 100))) 106.63176026064345)
  57.   (f2cl-lib:fset (f2cl-lib:fref gln (41) ((1 100))) 110.32063971475739)
  58.   (f2cl-lib:fset (f2cl-lib:fref gln (42) ((1 100))) 114.03421178146172)
  59.   (f2cl-lib:fset (f2cl-lib:fref gln (43) ((1 100))) 117.77188139974508)
  60.   (f2cl-lib:fset (f2cl-lib:fref gln (44) ((1 100))) 121.53308151543862)
  61.   (f2cl-lib:fset (f2cl-lib:fref gln (45) ((1 100))) 125.31727114935688)
  62.   (f2cl-lib:fset (f2cl-lib:fref gln (46) ((1 100))) 129.12393363912722)
  63.   (f2cl-lib:fset (f2cl-lib:fref gln (47) ((1 100))) 132.9525750356163)
  64.   (f2cl-lib:fset (f2cl-lib:fref gln (48) ((1 100))) 136.80272263732635)
  65.   (f2cl-lib:fset (f2cl-lib:fref gln (49) ((1 100))) 140.67392364823425)
  66.   (f2cl-lib:fset (f2cl-lib:fref gln (50) ((1 100))) 144.5657439463449)
  67.   (f2cl-lib:fset (f2cl-lib:fref gln (51) ((1 100))) 148.47776695177305)
  68.   (f2cl-lib:fset (f2cl-lib:fref gln (52) ((1 100))) 152.40959258449735)
  69.   (f2cl-lib:fset (f2cl-lib:fref gln (53) ((1 100))) 156.36083630307877)
  70.   (f2cl-lib:fset (f2cl-lib:fref gln (54) ((1 100))) 160.3311282166309)
  71.   (f2cl-lib:fset (f2cl-lib:fref gln (55) ((1 100))) 164.32011226319517)
  72.   (f2cl-lib:fset (f2cl-lib:fref gln (56) ((1 100))) 168.32744544842765)
  73.   (f2cl-lib:fset (f2cl-lib:fref gln (57) ((1 100))) 172.35279713916282)
  74.   (f2cl-lib:fset (f2cl-lib:fref gln (58) ((1 100))) 176.39584840699735)
  75.   (f2cl-lib:fset (f2cl-lib:fref gln (59) ((1 100))) 180.45629141754378)
  76.   (f2cl-lib:fset (f2cl-lib:fref gln (60) ((1 100))) 184.53382886144948)
  77.   (f2cl-lib:fset (f2cl-lib:fref gln (61) ((1 100))) 188.6281734236716)
  78.   (f2cl-lib:fset (f2cl-lib:fref gln (62) ((1 100))) 192.7390472878449)
  79.   (f2cl-lib:fset (f2cl-lib:fref gln (63) ((1 100))) 196.86618167288998)
  80.   (f2cl-lib:fset (f2cl-lib:fref gln (64) ((1 100))) 201.00931639928152)
  81.   (f2cl-lib:fset (f2cl-lib:fref gln (65) ((1 100))) 205.16819948264117)
  82.   (f2cl-lib:fset (f2cl-lib:fref gln (66) ((1 100))) 209.34258675253682)
  83.   (f2cl-lib:fset (f2cl-lib:fref gln (67) ((1 100))) 213.53224149456324)
  84.   (f2cl-lib:fset (f2cl-lib:fref gln (68) ((1 100))) 217.7369341139542)
  85.   (f2cl-lib:fset (f2cl-lib:fref gln (69) ((1 100))) 221.95644181913033)
  86.   (f2cl-lib:fset (f2cl-lib:fref gln (70) ((1 100))) 226.1905483237276)
  87.   (f2cl-lib:fset (f2cl-lib:fref gln (71) ((1 100))) 230.43904356577696)
  88.   (f2cl-lib:fset (f2cl-lib:fref gln (72) ((1 100))) 234.70172344281826)
  89.   (f2cl-lib:fset (f2cl-lib:fref gln (73) ((1 100))) 238.9783895618343)
  90.   (f2cl-lib:fset (f2cl-lib:fref gln (74) ((1 100))) 243.2688490029827)
  91.   (f2cl-lib:fset (f2cl-lib:fref gln (75) ((1 100))) 247.57291409618688)
  92.   (f2cl-lib:fset (f2cl-lib:fref gln (76) ((1 100))) 251.89040220972322)
  93.   (f2cl-lib:fset (f2cl-lib:fref gln (77) ((1 100))) 256.22113555000954)
  94.   (f2cl-lib:fset (f2cl-lib:fref gln (78) ((1 100))) 260.5649409718632)
  95.   (f2cl-lib:fset (f2cl-lib:fref gln (79) ((1 100))) 264.9216497985528)
  96.   (f2cl-lib:fset (f2cl-lib:fref gln (80) ((1 100))) 269.29109765101987)
  97.   (f2cl-lib:fset (f2cl-lib:fref gln (81) ((1 100))) 273.6731242856937)
  98.   (f2cl-lib:fset (f2cl-lib:fref gln (82) ((1 100))) 278.0675734403661)
  99.   (f2cl-lib:fset (f2cl-lib:fref gln (83) ((1 100))) 282.4742926876304)
  100.   (f2cl-lib:fset (f2cl-lib:fref gln (84) ((1 100))) 286.893133295427)
  101.   (f2cl-lib:fset (f2cl-lib:fref gln (85) ((1 100))) 291.32395009427034)
  102.   (f2cl-lib:fset (f2cl-lib:fref gln (86) ((1 100))) 295.76660135076065)
  103.   (f2cl-lib:fset (f2cl-lib:fref gln (87) ((1 100))) 300.2209486470141)
  104.   (f2cl-lib:fset (f2cl-lib:fref gln (88) ((1 100))) 304.6868567656687)
  105.   (f2cl-lib:fset (f2cl-lib:fref gln (89) ((1 100))) 309.16419358014696)
  106.   (f2cl-lib:fset (f2cl-lib:fref gln (90) ((1 100))) 313.65282994987905)
  107.   (f2cl-lib:fset (f2cl-lib:fref gln (91) ((1 100))) 318.1526396202093)
  108.   (f2cl-lib:fset (f2cl-lib:fref gln (92) ((1 100))) 322.6634991267262)
  109.   (f2cl-lib:fset (f2cl-lib:fref gln (93) ((1 100))) 327.1852877037752)
  110.   (f2cl-lib:fset (f2cl-lib:fref gln (94) ((1 100))) 331.7178871969285)
  111.   (f2cl-lib:fset (f2cl-lib:fref gln (95) ((1 100))) 336.26118197919845)
  112.   (f2cl-lib:fset (f2cl-lib:fref gln (96) ((1 100))) 340.815058870799)
  113.   (f2cl-lib:fset (f2cl-lib:fref gln (97) ((1 100))) 345.37940706226686)
  114.   (f2cl-lib:fset (f2cl-lib:fref gln (98) ((1 100))) 349.95411804077025)
  115.   (f2cl-lib:fset (f2cl-lib:fref gln (99) ((1 100))) 354.5390855194408)
  116.   (f2cl-lib:fset (f2cl-lib:fref gln (100) ((1 100))) 359.1342053695754)
  117.   (f2cl-lib:fset (f2cl-lib:fref cf (1) ((1 22))) 0.08333333333333334)
  118.   (f2cl-lib:fset (f2cl-lib:fref cf (2) ((1 22))) -0.002777777777777778)
  119.   (f2cl-lib:fset (f2cl-lib:fref cf (3) ((1 22))) 7.936507936507938e-4)
  120.   (f2cl-lib:fset (f2cl-lib:fref cf (4) ((1 22))) -5.952380952380953e-4)
  121.   (f2cl-lib:fset (f2cl-lib:fref cf (5) ((1 22))) 8.417508417508417e-4)
  122.   (f2cl-lib:fset (f2cl-lib:fref cf (6) ((1 22))) -0.0019175269175269176)
  123.   (f2cl-lib:fset (f2cl-lib:fref cf (7) ((1 22))) 0.006410256410256411)
  124.   (f2cl-lib:fset (f2cl-lib:fref cf (8) ((1 22))) -0.029550653594771242)
  125.   (f2cl-lib:fset (f2cl-lib:fref cf (9) ((1 22))) 0.17964437236883057)
  126.   (f2cl-lib:fset (f2cl-lib:fref cf (10) ((1 22))) -1.3924322169059011)
  127.   (f2cl-lib:fset (f2cl-lib:fref cf (11) ((1 22))) 13.402864044168393)
  128.   (f2cl-lib:fset (f2cl-lib:fref cf (12) ((1 22))) -156.84828462600203)
  129.   (f2cl-lib:fset (f2cl-lib:fref cf (13) ((1 22))) 2193.103333333333)
  130.   (f2cl-lib:fset (f2cl-lib:fref cf (14) ((1 22))) -36108.77125372499)
  131.   (f2cl-lib:fset (f2cl-lib:fref cf (15) ((1 22))) 691472.268851313)
  132.   (f2cl-lib:fset (f2cl-lib:fref cf (16) ((1 22))) -1.5238221539407418e+7)
  133.   (f2cl-lib:fset (f2cl-lib:fref cf (17) ((1 22))) 3.829007513914141e+8)
  134.   (f2cl-lib:fset (f2cl-lib:fref cf (18) ((1 22))) -1.0882266035784391e+10)
  135.   (f2cl-lib:fset (f2cl-lib:fref cf (19) ((1 22))) 3.473202837650023e+11)
  136.   (f2cl-lib:fset (f2cl-lib:fref cf (20) ((1 22))) -1.2369602142269272e+13)
  137.   (f2cl-lib:fset (f2cl-lib:fref cf (21) ((1 22))) 4.887880647930794e+14)
  138.   (f2cl-lib:fset (f2cl-lib:fref cf (22) ((1 22))) -2.1320333960919371e+16)
  139.   (defun dgamln (z ierr)
  140.     (declare (type f2cl-lib:integer4 ierr) (type double-float z))
  141.     (prog ((i 0) (i1m 0) (k 0) (mz 0) (nz 0) (fln 0.0) (fz 0.0) (rln 0.0)
  142.            (s 0.0) (tlg 0.0) (trm 0.0) (tst 0.0) (t1 0.0) (wdtol 0.0)
  143.            (zdmy 0.0) (zinc 0.0) (zm 0.0) (zmin 0.0) (zp 0.0) (zsq 0.0)
  144.            (dgamln 0.0))
  145.       (declare
  146.        (type double-float dgamln zsq zp zmin zm zinc zdmy wdtol t1 tst trm tlg
  147.         s rln fz fln)
  148.        (type f2cl-lib:integer4 nz mz k i1m i))
  149.       (setf ierr 0)
  150.       (if (<= z 0.0) (go label70))
  151.       (if (> z 101.0) (go label10))
  152.       (setf nz (f2cl-lib:int z))
  153.       (setf fz (- z nz))
  154.       (if (> fz 0.0) (go label10))
  155.       (if (> nz 100) (go label10))
  156.       (setf dgamln (f2cl-lib:fref gln (nz) ((1 100))))
  157.       (go end_label)
  158.      label10
  159.       (setf wdtol (f2cl-lib:d1mach 4))
  160.       (setf wdtol (max wdtol 5.0e-19))
  161.       (setf i1m (f2cl-lib:i1mach 14))
  162.       (setf rln (* (f2cl-lib:d1mach 5) i1m))
  163.       (setf fln (min rln 20.0))
  164.       (setf fln (max fln 3.0))
  165.       (setf fln (- fln 3.0))
  166.       (setf zm (+ 1.8 (* 0.3875 fln)))
  167.       (setf mz (f2cl-lib:int (+ zm 1)))
  168.       (setf zmin (coerce (the f2cl-lib:integer4 mz) 'double-float))
  169.       (setf zdmy z)
  170.       (setf zinc 0.0)
  171.       (if (>= z zmin) (go label20))
  172.       (setf zinc (- zmin nz))
  173.       (setf zdmy (+ z zinc))
  174.      label20
  175.       (setf zp (/ 1.0 zdmy))
  176.       (setf t1 (* (f2cl-lib:fref cf (1) ((1 22))) zp))
  177.       (setf s t1)
  178.       (if (< zp wdtol) (go label40))
  179.       (setf zsq (* zp zp))
  180.       (setf tst (* t1 wdtol))
  181.       (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1))
  182.                     ((> k 22) nil)
  183.         (tagbody
  184.           (setf zp (* zp zsq))
  185.           (setf trm (* (f2cl-lib:fref cf (k) ((1 22))) zp))
  186.           (if (< (abs trm) tst) (go label40))
  187.           (setf s (+ s trm))
  188.          label30))
  189.      label40
  190.       (if (/= zinc 0.0) (go label50))
  191.       (setf tlg (f2cl-lib:flog z))
  192.       (setf dgamln (+ (* z (- tlg 1.0)) (* 0.5 (- con tlg)) s))
  193.       (go end_label)
  194.      label50
  195.       (setf zp 1.0)
  196.       (setf nz (f2cl-lib:int zinc))
  197.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  198.                     ((> i nz) nil)
  199.         (tagbody (setf zp (* zp (+ z (f2cl-lib:int-sub i 1)))) label60))
  200.       (setf tlg (f2cl-lib:flog zdmy))
  201.       (setf dgamln
  202.               (+ (- (* zdmy (- tlg 1.0)) (f2cl-lib:flog zp))
  203.                  (* 0.5 (- con tlg))
  204.                  s))
  205.       (go end_label)
  206.      label70
  207.       (setf dgamln (f2cl-lib:d1mach 2))
  208.       (setf ierr 1)
  209.       (go end_label)
  210.      end_label
  211.       (return (values dgamln nil ierr)))))
  212.  
  213.