src/numerical/slatec/d9lgmc.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 (let ((nalgm 0)
  21       (xbig 0.0)
  22       (xmax 0.0)
  23       (algmcs
  24        (make-array 15
  25                    :element-type 'double-float
  26                    :initial-contents '(0.16663894804518634
  27                                        -1.384948176067564e-5
  28                                        9.81082564692473e-9
  29                                        -1.809129475572494e-11
  30                                        6.221098041892606e-14
  31                                        -3.399615005417722e-16
  32                                        2.683181998482699e-18
  33                                        -2.868042435334643e-20
  34                                        3.9628370610464347e-22
  35                                        -6.831888753985767e-24
  36                                        1.4292273559424982e-25
  37                                        -3.5475981581010704e-27
  38                                        1.025680058010471e-28
  39                                        -3.401102254316749e-30
  40                                        1.276642195630063e-31)))
  41       (first$ nil))
  42   (declare (type (f2cl-lib:integer4) nalgm)
  43            (type (double-float) xbig xmax)
  44            (type (simple-array double-float (15)) algmcs)
  45            (type f2cl-lib:logical first$))
  46   (setq first$ f2cl-lib:%true%)
  47   (defun d9lgmc (x)
  48     (declare (type (double-float) x))
  49     (prog ((d9lgmc 0.0))
  50       (declare (type (double-float) d9lgmc))
  51       (cond
  52         (first$
  53          (setf nalgm (initds algmcs 15 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
  54          (setf xbig (/ 1.0 (f2cl-lib:fsqrt (f2cl-lib:d1mach 3))))
  55          (setf xmax
  56                  (exp
  57                   (min (f2cl-lib:flog (/ (f2cl-lib:d1mach 2) 12.0))
  58                        (- (f2cl-lib:flog (* 12.0 (f2cl-lib:d1mach 1)))))))))
  59       (setf first$ f2cl-lib:%false%)
  60       (if (< x 10.0) (xermsg "SLATEC" "D9LGMC" "X MUST BE GE 10" 1 2))
  61       (if (>= x xmax) (go label20))
  62       (setf d9lgmc (/ 1.0 (* 12.0 x)))
  63       (if (< x xbig)
  64           (setf d9lgmc
  65                   (/ (dcsevl (- (* 2.0 (expt (/ 10.0 x) 2)) 1.0) algmcs nalgm)
  66                      x)))
  67       (go end_label)
  68      label20
  69       (setf d9lgmc 0.0)
  70       (xermsg "SLATEC" "D9LGMC" "X SO BIG D9LGMC UNDERFLOWS" 2 1)
  71       (go end_label)
  72      end_label
  73       (return (values d9lgmc nil)))))
  74
  75 (in-package #:cl-user)
  76 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  77 (eval-when (:load-toplevel :compile-toplevel :execute)
  78   (setf (gethash 'fortran-to-lisp::d9lgmc
  79                  fortran-to-lisp::*f2cl-function-info*)
  80           (fortran-to-lisp::make-f2cl-finfo :arg-types '((double-float))
  81                                             :return-values '(nil)
  82                                             :calls '(fortran-to-lisp::dcsevl
  83                                                      fortran-to-lisp::xermsg
  84                                                      fortran-to-lisp::initds
  85                                                      fortran-to-lisp::d1mach))))
  86