src/numerical/slatec/dbsi1e.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 ((nti1 0)
  21       (ntai1 0)
  22       (ntai12 0)
  23       (xmin 0.0)
  24       (xsml 0.0)
  25       (bi1cs
  26        (make-array 17
  27                    :element-type 'double-float
  28                    :initial-contents '(-0.0019717132610998596
  29                                        0.4073488766754648 0.03483899429995946
  30                                        0.0015453945563001237
  31                                        4.188852109837778e-5
  32                                        7.649026764836211e-7
  33                                        1.0042493924741179e-8
  34                                        9.93220779192381e-11
  35                                        7.663801791844764e-13
  36                                        4.741418923816739e-15
  37                                        2.404114404074518e-17
  38                                        1.0171505007093713e-19
  39                                        3.6450935657866947e-22
  40                                        1.1205749502562039e-24
  41                                        2.987544193446809e-27
  42                                        6.973231093919471e-30
  43                                        1.43679482206208e-32)))
  44       (ai1cs
  45        (make-array 46
  46                    :element-type 'double-float
  47                    :initial-contents '(-0.028467441818814786
  48                                        -0.019229532314432207
  49                                        -6.115185857943788e-4
  50                                        -2.0699712533502276e-5
  51                                        8.585619145810725e-6
  52                                        1.049498246711591e-6
  53                                        -2.9183389184479024e-7
  54                                        -1.559378146631739e-8
  55                                        1.3180123671449447e-8
  56                                        -1.4484234181830783e-9
  57                                        -2.908512243993142e-10
  58                                        1.2663889178753824e-10
  59                                        -1.6649477729192206e-11
  60                                        -1.666653644609433e-12
  61                                        1.2426024142907682e-12
  62                                        -2.731549379672432e-13
  63                                        2.0239478816458037e-14
  64                                        7.307950018116884e-15
  65                                        -3.332905634404675e-15
  66                                        7.175346558512954e-16
  67                                        -6.982530324796256e-17
  68                                        -1.2999442015627607e-17
  69                                        8.1209428642428e-18
  70                                        -2.194016207410737e-18
  71                                        3.6305161700296547e-19
  72                                        -1.6951397724391042e-20
  73                                        -1.2881848298979078e-20
  74                                        5.694428604967053e-21
  75                                        -1.4595970090904801e-21
  76                                        2.5145460106757173e-22
  77                                        -1.8447588831391248e-23
  78                                        -6.339760596227949e-24
  79                                        3.461441102031011e-24
  80                                        -1.0170623353713936e-24
  81                                        2.1498771470904314e-25
  82                                        -3.045252425238676e-26
  83                                        5.238082144721286e-28
  84                                        1.4435831070893824e-27
  85                                        -6.121302074890043e-28
  86                                        1.7000111174678184e-28
  87                                        -3.5965891079842444e-29
  88                                        5.448178578948419e-30
  89                                        -2.731831789689085e-31
  90                                        -1.8589050217086006e-31
  91                                        9.212682974513933e-32
  92                                        -2.8138351556535614e-32)))
  93       (ai12cs
  94        (make-array 69
  95                    :element-type 'double-float
  96                    :initial-contents '(0.02857623501828012
  97                                        -0.009761097491361469
  98                                        -1.1058893876262371e-4
  99                                        -3.882564808877691e-6
 100                                        -2.512236237870209e-7
 101                                        -2.6314688468895196e-8
 102                                        -3.835380385964237e-9
 103                                        -5.589743462196584e-10
 104                                        -1.8974958123505413e-11
 105                                        3.2526035830154884e-11
 106                                        1.4125807436613782e-11
 107                                        2.0356285441470896e-12
 108                                        -7.198551776245908e-13
 109                                        -4.0835511110921974e-13
 110                                        -2.1015418427726643e-14
 111                                        4.272440016711951e-14
 112                                        1.0420276984128802e-14
 113                                        -3.8144030724370075e-15
 114                                        -1.8803547755107825e-15
 115                                        3.3082023109209285e-16
 116                                        2.96262899764595e-16
 117                                        -3.209525921993424e-17
 118                                        -4.6503053684893586e-17
 119                                        4.414348323071708e-18
 120                                        7.517296310842105e-18
 121                                        -9.314178867326884e-19
 122                                        -1.242193275194891e-18
 123                                        2.4142767194548486e-19
 124                                        2.0269443840532852e-19
 125                                        -6.394267188269098e-20
 126                                        -3.049812452373096e-20
 127                                        1.6128418516514802e-20
 128                                        3.560913964309925e-21
 129                                        -3.752017947936439e-21
 130                                        -5.787037427074799e-23
 131                                        7.759997511648162e-22
 132                                        -1.4527908972022333e-22
 133                                        -1.3182252867390368e-22
 134                                        6.11665486290307e-23
 135                                        1.3762797624271266e-23
 136                                        -1.690837689959348e-23
 137                                        1.4305960885954331e-24
 138                                        3.409557828090594e-24
 139                                        -1.3094576662707602e-24
 140                                        -3.9407064112402574e-25
 141                                        4.277137426980877e-25
 142                                        -4.4246348309826066e-26
 143                                        -8.734113196230715e-26
 144                                        4.0454013356835337e-26
 145                                        7.06710065809469e-27
 146                                        -1.2494633445651053e-26
 147                                        2.867392244403437e-27
 148                                        2.0442928925042927e-27
 149                                        -1.5186366338204625e-27
 150                                        8.110181098187576e-29
 151                                        3.580379354773586e-28
 152                                        -1.6929290189279025e-28
 153                                        -2.2229024997024276e-29
 154                                        5.424535127145969e-29
 155                                        -1.7870684015780186e-29
 156                                        -6.565479068722815e-30
 157                                        7.807013165061145e-30
 158                                        -1.8165952606689797e-30
 159                                        -1.2877049526600847e-30
 160                                        1.1145481729881646e-30
 161                                        -1.8083431450393369e-31
 162                                        -2.231677718203772e-31
 163                                        1.6190295960803416e-31
 164                                        -1.8340799088049413e-32)))
 165       (first$ nil))
 166   (declare (type (f2cl-lib:integer4) nti1 ntai1 ntai12)
 167            (type (double-float) xmin xsml)
 168            (type (simple-array double-float (17)) bi1cs)
 169            (type (simple-array double-float (46)) ai1cs)
 170            (type (simple-array double-float (69)) ai12cs)
 171            (type f2cl-lib:logical first$))
 172   (setq first$ f2cl-lib:%true%)
 173   (defun dbsi1e (x)
 174     (declare (type (double-float) x))
 175     (prog ((y 0.0) (dbsi1e 0.0) (eta 0.0f0))
 176       (declare (type (single-float) eta) (type (double-float) dbsi1e y))
 177       (cond
 178         (first$
 179          (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
 180          (setf nti1 (initds bi1cs 17 eta))
 181          (setf ntai1 (initds ai1cs 46 eta))
 182          (setf ntai12 (initds ai12cs 69 eta))
 183          (setf xmin (* 2.0 (f2cl-lib:d1mach 1)))
 184          (setf xsml (f2cl-lib:fsqrt (* 4.5 (f2cl-lib:d1mach 3))))))
 185       (setf first$ f2cl-lib:%false%)
 186       (setf y (abs x))
 187       (if (> y 3.0) (go label20))
 188       (setf dbsi1e 0.0)
 189       (if (= y 0.0) (go end_label))
 190       (if (<= y xmin)
 191           (xermsg "SLATEC" "DBSI1E" "ABS(X) SO SMALL I1 UNDERFLOWS" 1 1))
 192       (if (> y xmin) (setf dbsi1e (* 0.5 x)))
 193       (if (> y xsml)
 194           (setf dbsi1e
 195                   (* x (+ 0.875 (dcsevl (- (/ (* y y) 4.5) 1.0) bi1cs nti1)))))
 196       (setf dbsi1e (* (exp (- y)) dbsi1e))
 197       (go end_label)
 198      label20
 199       (if (<= y 8.0)
 200           (setf dbsi1e
 201                   (/ (+ 0.375 (dcsevl (/ (- (/ 48.0 y) 11.0) 5.0) ai1cs ntai1))
 202                      (f2cl-lib:fsqrt y))))
 203       (if (> y 8.0)
 204           (setf dbsi1e
 205                   (/ (+ 0.375 (dcsevl (- (/ 16.0 y) 1.0) ai12cs ntai12))
 206                      (f2cl-lib:fsqrt y))))
 207       (setf dbsi1e (f2cl-lib:sign dbsi1e x))
 208       (go end_label)
 209      end_label
 210       (return (values dbsi1e nil)))))
 211
 212 (in-package #:cl-user)
 213 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 214 (eval-when (:load-toplevel :compile-toplevel :execute)
 215   (setf (gethash 'fortran-to-lisp::dbsi1e
 216                  fortran-to-lisp::*f2cl-function-info*)
 217           (fortran-to-lisp::make-f2cl-finfo :arg-types '((double-float))
 218                                             :return-values '(nil)
 219                                             :calls '(fortran-to-lisp::dcsevl
 220                                                      fortran-to-lisp::xermsg
 221                                                      fortran-to-lisp::initds
 222                                                      fortran-to-lisp::d1mach))))
 223