src/numerical/slatec/dbsk0e.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 ((ntk0 0)
  21       (ntak0 0)
  22       (ntak02 0)
  23       (xsml 0.0)
  24       (bk0cs
  25        (make-array 16
  26                    :element-type 'double-float
  27                    :initial-contents '(-0.03532739323390277 0.3442898999246285
  28                                        0.0359799365153615 0.001264615411446926
  29                                        2.286212103119452e-5
  30                                        2.5347910790261494e-7
  31                                        1.904516377220209e-9
  32                                        1.0349695257633625e-11
  33                                        4.2598161427910826e-14
  34                                        1.3744654358807508e-16
  35                                        3.5708965285083736e-19
  36                                        7.631643660116437e-22
  37                                        1.365424988440782e-24
  38                                        2.075275266906668e-27
  39                                        2.7128142180729857e-30
  40                                        3.0825938879146666e-33)))
  41       (ak0cs
  42        (make-array 38
  43                    :element-type 'double-float
  44                    :initial-contents '(-0.07643947903327941
  45                                        -0.02235652605699819
  46                                        7.734181154693858e-4
  47                                        -4.281006688886099e-5
  48                                        3.0817001738629747e-6
  49                                        -2.639367222009665e-7
  50                                        2.563713036403469e-8
  51                                        -2.7427055499002012e-9
  52                                        3.1694296580974997e-10
  53                                        -3.902353286962184e-11
  54                                        5.068040698188575e-12
  55                                        -6.889574741007871e-13
  56                                        9.744978497825918e-14
  57                                        -1.4273328418845485e-14
  58                                        2.156412571021463e-15
  59                                        -3.3496542551495625e-16
  60                                        5.3352602169529114e-17
  61                                        -8.693669980890753e-18
  62                                        1.4464043478622123e-18
  63                                        -2.4528898255001297e-19
  64                                        4.2337545262321717e-20
  65                                        -7.427946526454465e-21
  66                                        1.3231505293926669e-21
  67                                        -2.3905871647396495e-22
  68                                        4.376827585923226e-23
  69                                        -8.113700607345117e-24
  70                                        1.521819913832173e-24
  71                                        -2.886041941483398e-25
  72                                        5.530620667054718e-26
  73                                        -1.0703773292498988e-26
  74                                        2.0910868931423843e-27
  75                                        -4.121713723646204e-28
  76                                        8.193483971121308e-29
  77                                        -1.6420002754592977e-29
  78                                        3.3161432814802274e-30
  79                                        -6.746863644145296e-31
  80                                        1.3824291463184248e-31
  81                                        -2.8518741673598326e-32)))
  82       (ak02cs
  83        (make-array 33
  84                    :element-type 'double-float
  85                    :initial-contents '(-0.012018698263075922
  86                                        -0.009174852691025696
  87                                        1.4445509317750059e-4
  88                                        -4.01361417543571e-6
  89                                        1.5678318108523108e-7
  90                                        -7.770110438521738e-9
  91                                        4.6111825761797177e-10
  92                                        -3.158592997860566e-11
  93                                        2.435018039365041e-12
  94                                        -2.0743313873983479e-13
  95                                        1.925787280589917e-14
  96                                        -1.927554805838956e-15
  97                                        2.0621980291978182e-16
  98                                        -2.3416851175792425e-17
  99                                        2.8059028106430423e-18
 100                                        -3.530507631161808e-19
 101                                        4.645295422935108e-20
 102                                        -6.368625941344267e-21
 103                                        9.069521310986516e-22
 104                                        -1.3379747854236907e-22
 105                                        2.0398360218599522e-23
 106                                        -3.2070274813678404e-24
 107                                        5.18974441366231e-25
 108                                        -8.629501497540573e-26
 109                                        1.47216118310256e-26
 110                                        -2.5730690238670112e-27
 111                                        4.601774086643516e-28
 112                                        -8.411555324201094e-29
 113                                        1.569806306635369e-29
 114                                        -2.988226453005758e-30
 115                                        5.7968313752168365e-31
 116                                        -1.1450359943476814e-31
 117                                        2.3012665942496828e-32)))
 118       (first$ nil))
 119   (declare (type (f2cl-lib:integer4) ntk0 ntak0 ntak02)
 120            (type (double-float) xsml)
 121            (type (simple-array double-float (16)) bk0cs)
 122            (type (simple-array double-float (38)) ak0cs)
 123            (type (simple-array double-float (33)) ak02cs)
 124            (type f2cl-lib:logical first$))
 125   (setq first$ f2cl-lib:%true%)
 126   (defun dbsk0e (x)
 127     (declare (type (double-float) x))
 128     (prog ((y 0.0) (dbsk0e 0.0) (eta 0.0f0))
 129       (declare (type (single-float) eta) (type (double-float) dbsk0e y))
 130       (cond
 131         (first$
 132          (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
 133          (setf ntk0 (initds bk0cs 16 eta))
 134          (setf ntak0 (initds ak0cs 38 eta))
 135          (setf ntak02 (initds ak02cs 33 eta))
 136          (setf xsml (f2cl-lib:fsqrt (* 4.0 (f2cl-lib:d1mach 3))))))
 137       (setf first$ f2cl-lib:%false%)
 138       (if (<= x 0.0) (xermsg "SLATEC" "DBSK0E" "X IS ZERO OR NEGATIVE" 2 2))
 139       (if (> x 2.0) (go label20))
 140       (setf y 0.0)
 141       (if (> x xsml) (setf y (* x x)))
 142       (setf dbsk0e
 143               (* (exp x)
 144                  (+ (- (* (- (f2cl-lib:flog (* 0.5 x))) (dbesi0 x)) 0.25)
 145                     (dcsevl (- (* 0.5 y) 1.0) bk0cs ntk0))))
 146       (go end_label)
 147      label20
 148       (if (<= x 8.0)
 149           (setf dbsk0e
 150                   (/ (+ 1.25 (dcsevl (/ (- (/ 16.0 x) 5.0) 3.0) ak0cs ntak0))
 151                      (f2cl-lib:fsqrt x))))
 152       (if (> x 8.0)
 153           (setf dbsk0e
 154                   (/ (+ 1.25 (dcsevl (- (/ 16.0 x) 1.0) ak02cs ntak02))
 155                      (f2cl-lib:fsqrt x))))
 156       (go end_label)
 157      end_label
 158       (return (values dbsk0e nil)))))
 159
 160 (in-package #:cl-user)
 161 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 162 (eval-when (:load-toplevel :compile-toplevel :execute)
 163   (setf (gethash 'fortran-to-lisp::dbsk0e
 164                  fortran-to-lisp::*f2cl-function-info*)
 165           (fortran-to-lisp::make-f2cl-finfo :arg-types '((double-float))
 166                                             :return-values '(nil)
 167                                             :calls '(fortran-to-lisp::dcsevl
 168                                                      fortran-to-lisp::dbesi0
 169                                                      fortran-to-lisp::xermsg
 170                                                      fortran-to-lisp::initds
 171                                                      fortran-to-lisp::d1mach))))
 172