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 / dai.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  4.3 KB  |  99 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 ((naif 0)
  12.       (naig 0)
  13.       (x3sml 0.0)
  14.       (xmax 0.0)
  15.       (aifcs (make-array 13 :element-type 'double-float))
  16.       (aigcs (make-array 13 :element-type 'double-float))
  17.       (first nil))
  18.   (declare (type f2cl-lib:logical first)
  19.            (type (simple-array double-float (13)) aigcs aifcs)
  20.            (type double-float xmax x3sml)
  21.            (type f2cl-lib:integer4 naig naif))
  22.   (f2cl-lib:fset (f2cl-lib:fref aifcs (1) ((1 13))) -0.03797135849667)
  23.   (f2cl-lib:fset (f2cl-lib:fref aifcs (2) ((1 13))) 0.05919188853726364)
  24.   (f2cl-lib:fset (f2cl-lib:fref aifcs (3) ((1 13))) 9.862928057727998e-4)
  25.   (f2cl-lib:fset (f2cl-lib:fref aifcs (4) ((1 13))) 6.848843819076567e-6)
  26.   (f2cl-lib:fset (f2cl-lib:fref aifcs (5) ((1 13))) 2.5942025962194715e-8)
  27.   (f2cl-lib:fset (f2cl-lib:fref aifcs (6) ((1 13))) 6.176612774081375e-11)
  28.   (f2cl-lib:fset (f2cl-lib:fref aifcs (7) ((1 13))) 1.0092454172466117e-13)
  29.   (f2cl-lib:fset (f2cl-lib:fref aifcs (8) ((1 13))) 1.2014792511179939e-16)
  30.   (f2cl-lib:fset (f2cl-lib:fref aifcs (9) ((1 13))) 1.0882945588716993e-19)
  31.   (f2cl-lib:fset (f2cl-lib:fref aifcs (10) ((1 13))) 7.751377219668488e-23)
  32.   (f2cl-lib:fset (f2cl-lib:fref aifcs (11) ((1 13))) 4.454811203717564e-26)
  33.   (f2cl-lib:fset (f2cl-lib:fref aifcs (12) ((1 13))) 2.1092845231692342e-29)
  34.   (f2cl-lib:fset (f2cl-lib:fref aifcs (13) ((1 13))) 8.370173591074134e-33)
  35.   (f2cl-lib:fset (f2cl-lib:fref aigcs (1) ((1 13))) 0.018152365581161272)
  36.   (f2cl-lib:fset (f2cl-lib:fref aigcs (2) ((1 13))) 0.021572563166010757)
  37.   (f2cl-lib:fset (f2cl-lib:fref aigcs (3) ((1 13))) 2.567835698748325e-4)
  38.   (f2cl-lib:fset (f2cl-lib:fref aigcs (4) ((1 13))) 1.4265214119792408e-6)
  39.   (f2cl-lib:fset (f2cl-lib:fref aigcs (5) ((1 13))) 4.572114920018043e-9)
  40.   (f2cl-lib:fset (f2cl-lib:fref aigcs (6) ((1 13))) 9.525170843564709e-12)
  41.   (f2cl-lib:fset (f2cl-lib:fref aigcs (7) ((1 13))) 1.39256346057714e-14)
  42.   (f2cl-lib:fset (f2cl-lib:fref aigcs (8) ((1 13))) 1.5070999142762379e-17)
  43.   (f2cl-lib:fset (f2cl-lib:fref aigcs (9) ((1 13))) 1.2559148312567775e-20)
  44.   (f2cl-lib:fset (f2cl-lib:fref aigcs (10) ((1 13))) 8.306307377082133e-24)
  45.   (f2cl-lib:fset (f2cl-lib:fref aigcs (11) ((1 13))) 4.4657538493718574e-27)
  46.   (f2cl-lib:fset (f2cl-lib:fref aigcs (12) ((1 13))) 1.9900855034518866e-30)
  47.   (f2cl-lib:fset (f2cl-lib:fref aigcs (13) ((1 13))) 7.470288525653334e-34)
  48.   (setq first f2cl-lib:%true%)
  49.   (defun dai (x)
  50.     (declare (type double-float x))
  51.     (prog ((theta 0.0) (xm 0.0) (z 0.0) (xmaxt 0.0) (dai 0.0))
  52.       (declare (type double-float dai xmaxt z xm theta))
  53.       (cond
  54.        (first
  55.         (setf naif
  56.                 (initds aifcs 13
  57.                  (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3)))))
  58.         (setf naig
  59.                 (initds aigcs 13
  60.                  (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3)))))
  61.         (setf x3sml (expt (f2cl-lib:d1mach 3) 0.3334))
  62.         (setf xmaxt (expt (* -1.5 (f2cl-lib:flog (f2cl-lib:d1mach 1))) 0.6667))
  63.         (setf xmax
  64.                 (-
  65.                  (+ xmaxt
  66.                     (/ (* (- xmaxt) (f2cl-lib:flog xmaxt))
  67.                        (+ (* 4.0 (f2cl-lib:fsqrt xmaxt)) 1.0)))
  68.                  0.01))))
  69.       (setf first f2cl-lib:%false%)
  70.       (if (>= x -1.0) (go label20))
  71.       (multiple-value-bind
  72.           (var-0 var-1 var-2)
  73.           (d9aimp x xm theta)
  74.         (declare (ignore var-0))
  75.         (setf xm var-1)
  76.         (setf theta var-2))
  77.       (setf dai (* xm (cos theta)))
  78.       (go end_label)
  79.      label20
  80.       (if (> x 1.0) (go label30))
  81.       (setf z 0.0)
  82.       (if (> (abs x) x3sml) (setf z (expt x 3)))
  83.       (setf dai
  84.               (+ 0.375
  85.                  (- (dcsevl z aifcs naif)
  86.                     (* x (+ 0.25 (dcsevl z aigcs naig))))))
  87.       (go end_label)
  88.      label30
  89.       (if (> x xmax) (go label40))
  90.       (setf dai (* (daie x) (exp (/ (* -2.0 x (f2cl-lib:fsqrt x)) 3.0))))
  91.       (go end_label)
  92.      label40
  93.       (setf dai 0.0)
  94.       (xermsg "SLATEC" "DAI" "X SO BIG AI UNDERFLOWS" 1 1)
  95.       (go end_label)
  96.      end_label
  97.       (return (values dai nil)))))
  98.  
  99.