src/numerical/slatec/d9b0mp.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 ((nbm0 0)
  21       (nbt02 0)
  22       (nbm02 0)
  23       (nbth0 0)
  24       (xmax 0.0)
  25       (bm0cs
  26        (make-array 37
  27                    :element-type 'double-float
  28                    :initial-contents '(0.09211656246827743
  29                                        -0.0010505909972719051
  30                                        1.4701598407687597e-5
  31                                        -5.058557606038554e-7
  32                                        2.7872545386324443e-8
  33                                        -2.062363611780915e-9
  34                                        1.8702143131388797e-10
  35                                        -1.9693309711356362e-11
  36                                        2.3259737939992754e-12
  37                                        -3.0095203449382503e-13
  38                                        4.1945213338506693e-14
  39                                        -6.219449312188446e-15
  40                                        9.71826041133607e-16
  41                                        -1.5884785857010752e-16
  42                                        2.7000721936713088e-17
  43                                        -4.7500923652340086e-18
  44                                        8.615128162604371e-19
  45                                        -1.6056086869561448e-19
  46                                        3.066513987314483e-20
  47                                        -5.987764223193956e-21
  48                                        1.1929712537482484e-21
  49                                        -2.4209691420448057e-22
  50                                        4.9967517605106164e-23
  51                                        -1.0474936393511585e-23
  52                                        2.2277868437974682e-24
  53                                        -4.801813239398163e-25
  54                                        1.04796272347096e-25
  55                                        -2.3138581656786152e-26
  56                                        5.164823088462674e-27
  57                                        -1.1646911918500655e-27
  58                                        2.651788486043319e-28
  59                                        -6.092559503825728e-29
  60                                        1.4118046861442593e-29
  61                                        -3.298094961231737e-30
  62                                        7.763931143074065e-31
  63                                        -1.8410313436614585e-31
  64                                        4.395880138594311e-32)))
  65       (bth0cs
  66        (make-array 44
  67                    :element-type 'double-float
  68                    :initial-contents '(-0.24901780862128936
  69                                        4.855029960962375e-4
  70                                        -5.4511837345017206e-6
  71                                        1.3558673059405963e-7
  72                                        -5.5691398902227624e-9
  73                                        3.2609031824994337e-10
  74                                        -2.491880786246134e-11
  75                                        2.344937742088252e-12
  76                                        -2.609653444431039e-13
  77                                        3.3353140420097393e-14
  78                                        -4.789000044057268e-15
  79                                        7.595617843619222e-16
  80                                        -1.3131556016891442e-16
  81                                        2.4483618345240857e-17
  82                                        -4.880572981061878e-18
  83                                        1.0327285029786316e-18
  84                                        -2.3057633815057217e-19
  85                                        5.404444300189269e-20
  86                                        -1.3240695194366572e-20
  87                                        3.378079562137197e-21
  88                                        -8.945762915711178e-22
  89                                        2.4519906889219317e-22
  90                                        -6.938842287686632e-23
  91                                        2.022827871489014e-23
  92                                        -6.062850000233549e-24
  93                                        1.8649748964037634e-24
  94                                        -5.878373238484989e-25
  95                                        1.8958591447999562e-25
  96                                        -6.248197937225886e-26
  97                                        2.1017901684551025e-26
  98                                        -7.208430093520926e-27
  99                                        2.5181363892474242e-27
 100                                        -8.951804225878578e-28
 101                                        3.23572374797623e-28
 102                                        -1.1883010519855353e-28
 103                                        4.4306286907358106e-29
 104                                        -1.676100964883483e-29
 105                                        6.429294692120746e-30
 106                                        -2.499226116697865e-30
 107                                        9.839979429952196e-31
 108                                        -3.9220375242408017e-31
 109                                        1.5818107030056521e-31
 110                                        -6.452550614489072e-32
 111                                        2.6611111369199356e-32)))
 112       (bm02cs
 113        (make-array 40
 114                    :element-type 'double-float
 115                    :initial-contents '(0.09500415145228382
 116                                        -3.801864682365671e-4
 117                                        2.258339301031481e-6
 118                                        -3.895725802372229e-8
 119                                        1.2468864165120817e-9
 120                                        -6.065949022102504e-11
 121                                        4.008461651421747e-12
 122                                        -3.3509981833980945e-13
 123                                        3.3771197165174173e-14
 124                                        -3.964585901635013e-15
 125                                        5.286111503883857e-16
 126                                        -7.852519083450852e-17
 127                                        1.2803005733866823e-17
 128                                        -2.26399629639143e-18
 129                                        4.3004969296567905e-19
 130                                        -8.705749805132587e-20
 131                                        1.8658627139620952e-20
 132                                        -4.210482486093065e-21
 133                                        9.9566769642284e-22
 134                                        -2.457357442805313e-22
 135                                        6.307692160762032e-23
 136                                        -1.6787736914407402e-23
 137                                        4.6202590646739044e-24
 138                                        -1.3117822668603088e-24
 139                                        3.834087564116303e-25
 140                                        -1.1514593240777412e-25
 141                                        3.547210007523339e-26
 142                                        -1.1192183858150046e-26
 143                                        3.611879427629838e-27
 144                                        -1.1906877659133332e-27
 145                                        4.005094059403968e-28
 146                                        -1.3731694224522124e-28
 147                                        4.7941990887425316e-29
 148                                        -1.7029656276241095e-29
 149                                        6.14951242893633e-30
 150                                        -2.2557668965818283e-30
 151                                        8.3997075092943e-31
 152                                        -3.1729975955626022e-31
 153                                        1.2152052988812985e-31
 154                                        -4.7158527497544386e-32)))
 155       (bt02cs
 156        (make-array 39
 157                    :element-type 'double-float
 158                    :initial-contents '(-0.24548295213424598
 159                                        0.0012544121039084616
 160                                        -3.1253950414871526e-5
 161                                        1.4709778249940832e-6
 162                                        -9.954348893795004e-8
 163                                        8.549316673320304e-9
 164                                        -8.698975952655434e-10
 165                                        1.0052099533559791e-10
 166                                        -1.2828230601708893e-11
 167                                        1.7731700781805131e-12
 168                                        -2.617457456948558e-13
 169                                        4.082835138997206e-14
 170                                        -6.675166823974272e-15
 171                                        1.136576139307163e-15
 172                                        -2.005118962064716e-16
 173                                        3.649797879476627e-17
 174                                        -6.8309637564582306e-18
 175                                        1.3107583145670756e-18
 176                                        -2.5723363101850606e-19
 177                                        5.152165744186396e-20
 178                                        -1.0513017563758802e-20
 179                                        2.1820381991194814e-21
 180                                        -4.600470121036216e-22
 181                                        9.840700692546682e-23
 182                                        -2.1334038035728374e-23
 183                                        4.683103642397336e-24
 184                                        -1.0400213691985747e-24
 185                                        2.334910567730151e-25
 186                                        -5.295682532331862e-26
 187                                        1.2126341952959756e-26
 188                                        -2.801889708228943e-27
 189                                        6.529267898701287e-28
 190                                        -1.5337980061873346e-28
 191                                        3.6305884306364537e-29
 192                                        -8.656075571362912e-30
 193                                        2.0779909972536286e-30
 194                                        -5.021117022141722e-31
 195                                        1.2208360279441715e-31
 196                                        -2.986005626703991e-32)))
 197       (pi4 0.7853981633974483)
 198       (first$ nil))
 199   (declare (type (f2cl-lib:integer4) nbm0 nbt02 nbm02 nbth0)
 200            (type (double-float) xmax pi4)
 201            (type (simple-array double-float (37)) bm0cs)
 202            (type (simple-array double-float (44)) bth0cs)
 203            (type (simple-array double-float (40)) bm02cs)
 204            (type (simple-array double-float (39)) bt02cs)
 205            (type f2cl-lib:logical first$))
 206   (setq first$ f2cl-lib:%true%)
 207   (defun d9b0mp (x ampl theta)
 208     (declare (type (double-float) theta ampl x))
 209     (prog ((z 0.0) (eta 0.0f0))
 210       (declare (type (single-float) eta) (type (double-float) z))
 211       (cond
 212         (first$
 213          (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
 214          (setf nbm0 (initds bm0cs 37 eta))
 215          (setf nbt02 (initds bt02cs 39 eta))
 216          (setf nbm02 (initds bm02cs 40 eta))
 217          (setf nbth0 (initds bth0cs 44 eta))
 218          (setf xmax (/ 1.0 (f2cl-lib:d1mach 4)))))
 219       (setf first$ f2cl-lib:%false%)
 220       (if (< x 4.0) (xermsg "SLATEC" "D9B0MP" "X MUST BE GE 4" 1 2))
 221       (if (> x 8.0) (go label20))
 222       (setf z (/ (- (/ 128.0 (* x x)) 5.0) 3.0))
 223       (setf ampl (/ (+ 0.75 (dcsevl z bm0cs nbm0)) (f2cl-lib:fsqrt x)))
 224       (setf theta (+ (- x pi4) (/ (dcsevl z bt02cs nbt02) x)))
 225       (go end_label)
 226      label20
 227       (if (> x xmax)
 228           (xermsg "SLATEC" "D9B0MP" "NO PRECISION BECAUSE X IS BIG" 2 2))
 229       (setf z (- (/ 128.0 (* x x)) 1.0))
 230       (setf ampl (/ (+ 0.75 (dcsevl z bm02cs nbm02)) (f2cl-lib:fsqrt x)))
 231       (setf theta (+ (- x pi4) (/ (dcsevl z bth0cs nbth0) 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::d9b0mp
 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