src/numerical/slatec/dgamlm.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 (defun dgamlm (xmin xmax)
  21   (declare (type (double-float) xmax xmin))
  22   (prog ((alnbig 0.0) (alnsml 0.0) (xln 0.0) (xold 0.0) (i 0))
  23     (declare (type (f2cl-lib:integer4) i)
  24              (type (double-float) xold xln alnsml alnbig))
  25     (setf alnsml (f2cl-lib:flog (f2cl-lib:d1mach 1)))
  26     (setf xmin (- alnsml))
  27     (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  28                   ((> i 10) nil)
  29       (tagbody
  30         (setf xold xmin)
  31         (setf xln (f2cl-lib:flog xmin))
  32         (setf xmin
  33                 (+ xmin
  34                    (/
  35                     (* (- xmin)
  36                        (+ (- (* (+ xmin 0.5) xln) xmin 0.2258) alnsml))
  37                     (+ (* xmin xln) 0.5))))
  38         (if (< (abs (- xmin xold)) 0.005) (go label20))
  39        label10))
  40     (xermsg "SLATEC" "DGAMLM" "UNABLE TO FIND XMIN" 1 2)
  41    label20
  42     (setf xmin (- 0.01 xmin))
  43     (setf alnbig (f2cl-lib:flog (f2cl-lib:d1mach 2)))
  44     (setf xmax alnbig)
  45     (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  46                   ((> i 10) nil)
  47       (tagbody
  48         (setf xold xmax)
  49         (setf xln (f2cl-lib:flog xmax))
  50         (setf xmax
  51                 (+ xmax
  52                    (/
  53                     (* (- xmax)
  54                        (- (+ (- (* (- xmax 0.5) xln) xmax) 0.9189) alnbig))
  55                     (- (* xmax xln) 0.5))))
  56         (if (< (abs (- xmax xold)) 0.005) (go label40))
  57        label30))
  58     (xermsg "SLATEC" "DGAMLM" "UNABLE TO FIND XMAX" 2 2)
  59    label40
  60     (setf xmax (- xmax 0.01))
  61     (setf xmin (max xmin (- 1.0 xmax)))
  62     (go end_label)
  63    end_label
  64     (return (values xmin xmax))))
  65
  66 (in-package #:cl-user)
  67 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  68 (eval-when (:load-toplevel :compile-toplevel :execute)
  69   (setf (gethash 'fortran-to-lisp::dgamlm
  70                  fortran-to-lisp::*f2cl-function-info*)
  71           (fortran-to-lisp::make-f2cl-finfo
  72            :arg-types '((double-float) (double-float))
  73            :return-values '(fortran-to-lisp::xmin fortran-to-lisp::xmax)
  74            :calls '(fortran-to-lisp::xermsg fortran-to-lisp::d1mach))))
  75