src/numerical/slatec/d9b1mp.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 ((nbm1 0)
  21       (nbt12 0)
  22       (nbm12 0)
  23       (nbth1 0)
  24       (xmax 0.0)
  25       (bm1cs
  26        (make-array 37
  27                    :element-type 'double-float
  28                    :initial-contents '(0.1069845452618063 0.003274915039715965
  29                                        -2.9877832668316986e-5
  30                                        8.331237177991975e-7
  31                                        -4.1126656903020076e-8
  32                                        2.8553442287892154e-9
  33                                        -2.485408305415624e-10
  34                                        2.5433933380725825e-11
  35                                        -2.9410457728229675e-12
  36                                        3.7433920254939033e-13
  37                                        -5.149118293821167e-14
  38                                        7.552535949865144e-15
  39                                        -1.1694097068288465e-15
  40                                        1.8965624494347915e-16
  41                                        -3.2019553686932864e-17
  42                                        5.599548399316204e-18
  43                                        -1.0102158947304325e-18
  44                                        1.873844985727563e-19
  45                                        -3.5635374703285804e-20
  46                                        6.931283819971238e-21
  47                                        -1.3760594534065001e-21
  48                                        2.7834307841070803e-22
  49                                        -5.727595364320562e-23
  50                                        1.1973614459188927e-23
  51                                        -2.539928509891872e-24
  52                                        5.461378289657296e-25
  53                                        -1.1892113417733203e-25
  54                                        2.6201509773400816e-26
  55                                        -5.836810774255686e-27
  56                                        1.3137435000805957e-27
  57                                        -2.9858146225103804e-28
  58                                        6.848390471334604e-29
  59                                        -1.5844015682224767e-29
  60                                        3.695641006570938e-30
  61                                        -8.687115921144669e-31
  62                                        2.0570808461587635e-31
  63                                        -4.9052257611162255e-32)))
  64       (bt12cs
  65        (make-array 39
  66                    :element-type 'double-float
  67                    :initial-contents '(0.7382386012874298
  68                                        -0.0033361113174483906
  69                                        6.146345488804697e-5
  70                                        -2.4024585161602376e-6
  71                                        1.4663555577509747e-7
  72                                        -1.1841917305589181e-8
  73                                        1.1574198963919197e-9
  74                                        -1.3001161129439188e-10
  75                                        1.6245391141361733e-11
  76                                        -2.2089636821403188e-12
  77                                        3.218030425855318e-13
  78                                        -4.965314793276848e-14
  79                                        8.043890043284782e-15
  80                                        -1.3589121310161292e-15
  81                                        2.3810504397147215e-16
  82                                        -4.3081466363849105e-17
  83                                        8.0202544032771e-18
  84                                        -1.5316310642462312e-18
  85                                        2.9928606352715567e-19
  86                                        -5.970996465808544e-20
  87                                        1.2140289669415186e-20
  88                                        -2.511511469661295e-21
  89                                        5.279056717032874e-22
  90                                        -1.1260509227550498e-22
  91                                        2.4348277359576326e-23
  92                                        -5.33172612369318e-24
  93                                        1.1813615059707122e-24
  94                                        -2.646536828335352e-25
  95                                        5.99033940413615e-26
  96                                        -1.3690854630829503e-26
  97                                        3.1576790154380228e-27
  98                                        -7.345791508208436e-28
  99                                        1.7228081480722747e-28
 100                                        -4.0716907961286507e-29
 101                                        9.693474513677962e-30
 102                                        -2.3237636337765716e-30
 103                                        5.607451067352203e-31
 104                                        -1.3616465391539005e-31
 105                                        3.3263109233894654e-32)))
 106       (bm12cs
 107        (make-array 40
 108                    :element-type 'double-float
 109                    :initial-contents '(0.0980797915623305 0.0011509611895046852
 110                                        -4.312482164338206e-6
 111                                        5.951839610088816e-8
 112                                        -1.7048440198269098e-9
 113                                        7.798265413611109e-11
 114                                        -4.958986126766416e-12
 115                                        4.0384324164211416e-13
 116                                        -3.993046163725175e-14
 117                                        4.619886183118967e-15
 118                                        -6.089208019095383e-16
 119                                        8.960930916433877e-17
 120                                        -1.4496294239420233e-17
 121                                        2.546463158537776e-18
 122                                        -4.809472874647837e-19
 123                                        9.687684668292599e-20
 124                                        -2.067213372277966e-20
 125                                        4.6466515591503845e-21
 126                                        -1.0949661288483342e-21
 127                                        2.693892797288683e-22
 128                                        -6.894992910930374e-23
 129                                        1.830268262752063e-23
 130                                        -5.0250642463519166e-24
 131                                        1.423545194454806e-24
 132                                        -4.15219120361645e-25
 133                                        1.2446092015039794e-25
 134                                        -3.8273363705693045e-26
 135                                        1.2055913578156175e-26
 136                                        -3.884536246376488e-27
 137                                        1.2786895287204098e-27
 138                                        -4.295146689447946e-28
 139                                        1.4706891178290709e-28
 140                                        -5.128315665106074e-29
 141                                        1.8195095854711694e-29
 142                                        -6.563031314841981e-30
 143                                        2.4048989769199608e-30
 144                                        -8.945966744690612e-31
 145                                        3.376085160657231e-31
 146                                        -1.2917914546206564e-31
 147                                        5.008634462958811e-32)))
 148       (bth1cs
 149        (make-array 44
 150                    :element-type 'double-float
 151                    :initial-contents '(0.7474995720358728 -0.001240077714465171
 152                                        9.925244240442453e-6
 153                                        -2.030369073715971e-7
 154                                        7.535961770569089e-9
 155                                        -4.166161271534355e-10
 156                                        3.070161807083489e-11
 157                                        -2.817849963760521e-12
 158                                        3.0790696739040297e-13
 159                                        -3.8803300262803433e-14
 160                                        5.509603960863091e-15
 161                                        -8.659006076838378e-16
 162                                        1.4856049141536748e-16
 163                                        -2.7519529815904085e-17
 164                                        5.455079609048109e-18
 165                                        -1.1486534501983643e-18
 166                                        2.55352133779739e-19
 167                                        -5.962149019741345e-20
 168                                        1.4556622902372717e-20
 169                                        -3.702218542245054e-21
 170                                        9.776307412534536e-22
 171                                        -2.6726821639668487e-22
 172                                        7.545330038498327e-23
 173                                        -2.1947899919802746e-23
 174                                        6.564839462395526e-24
 175                                        -2.0155604298370206e-24
 176                                        6.341776855677614e-25
 177                                        -2.0419277885337895e-25
 178                                        6.719146422072056e-26
 179                                        -2.2569079110207573e-26
 180                                        7.72977198929897e-27
 181                                        -2.696744451229464e-27
 182                                        9.57493445185027e-28
 183                                        -3.4569168448890113e-28
 184                                        1.2681234817398437e-28
 185                                        -4.7232536630722637e-29
 186                                        1.7850008478186376e-29
 187                                        -6.84043610045104e-30
 188                                        2.656602867172042e-30
 189                                        -1.0450402527914452e-30
 190                                        4.161829082537715e-31
 191                                        -1.6771639203643716e-31
 192                                        6.836199777666439e-32
 193                                        -2.817224786123364e-32)))
 194       (pi4 0.7853981633974483)
 195       (first$ nil))
 196   (declare (type (f2cl-lib:integer4) nbm1 nbt12 nbm12 nbth1)
 197            (type (double-float) xmax pi4)
 198            (type (simple-array double-float (37)) bm1cs)
 199            (type (simple-array double-float (39)) bt12cs)
 200            (type (simple-array double-float (40)) bm12cs)
 201            (type (simple-array double-float (44)) bth1cs)
 202            (type f2cl-lib:logical first$))
 203   (setq first$ f2cl-lib:%true%)
 204   (defun d9b1mp (x ampl theta)
 205     (declare (type (double-float) theta ampl x))
 206     (prog ((z 0.0) (eta 0.0f0))
 207       (declare (type (single-float) eta) (type (double-float) z))
 208       (cond
 209         (first$
 210          (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
 211          (setf nbm1 (initds bm1cs 37 eta))
 212          (setf nbt12 (initds bt12cs 39 eta))
 213          (setf nbm12 (initds bm12cs 40 eta))
 214          (setf nbth1 (initds bth1cs 44 eta))
 215          (setf xmax (/ 1.0 (f2cl-lib:d1mach 4)))))
 216       (setf first$ f2cl-lib:%false%)
 217       (cond
 218         ((< x 4.0)
 219          (xermsg "SLATEC" "D9B1MP" "X must be  >=  4" 1 2)
 220          (setf ampl 0.0)
 221          (setf theta 0.0))
 222         ((<= x 8.0)
 223          (setf z (/ (- (/ 128.0 (* x x)) 5.0) 3.0))
 224          (setf ampl (/ (+ 0.75 (dcsevl z bm1cs nbm1)) (f2cl-lib:fsqrt x)))
 225          (setf theta (+ (- x (* 3.0 pi4)) (/ (dcsevl z bt12cs nbt12) x))))
 226         (t
 227          (if (> x xmax)
 228              (xermsg "SLATEC" "D9B1MP" "No precision because X is too big" 2 2))
 229          (setf z (- (/ 128.0 (* x x)) 1.0))
 230          (setf ampl (/ (+ 0.75 (dcsevl z bm12cs nbm12)) (f2cl-lib:fsqrt x)))
 231          (setf theta (+ (- x (* 3.0 pi4)) (/ (dcsevl z bth1cs nbth1) x)))))
 232       (go end_label)
 233      end_label
 234       (return (values nil ampl theta)))))
 235
 236 (in-package #:cl-user)
 237 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 238 (eval-when (:load-toplevel :compile-toplevel :execute)
 239   (setf (gethash 'fortran-to-lisp::d9b1mp
 240                  fortran-to-lisp::*f2cl-function-info*)
 241           (fortran-to-lisp::make-f2cl-finfo
 242            :arg-types '((double-float) (double-float) (double-float))
 243            :return-values '(nil fortran-to-lisp::ampl fortran-to-lisp::theta)
 244            :calls '(fortran-to-lisp::dcsevl fortran-to-lisp::xermsg
 245                     fortran-to-lisp::initds fortran-to-lisp::d1mach))))
 246