src/numerical/slatec/de1.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 ((ntae10 0)
  21       (ntae11 0)
  22       (ntae12 0)
  23       (nte11 0)
  24       (nte12 0)
  25       (ntae13 0)
  26       (ntae14 0)
  27       (xmax 0.0)
  28       (ae10cs
  29        (make-array 50
  30                    :element-type 'double-float
  31                    :initial-contents '(0.03284394579616699
  32                                        -0.016699204520313628
  33                                        2.845284724361347e-4
  34                                        -7.563944358516206e-6
  35                                        2.7989712894508593e-7
  36                                        -1.357901828534531e-8
  37                                        8.343596202040469e-10
  38                                        -6.370971727640248e-11
  39                                        6.007247608811861e-12
  40                                        -7.022876174679774e-13
  41                                        1.0183026737036877e-13
  42                                        -1.7618129034308802e-14
  43                                        3.2508286142353605e-15
  44                                        -5.071770025505819e-16
  45                                        1.6651773870432943e-17
  46                                        3.1667538907975144e-17
  47                                        -1.5884037636641416e-17
  48                                        4.175513256138019e-18
  49                                        -2.8923477497071417e-19
  50                                        -2.800625903396608e-19
  51                                        1.322938639539271e-19
  52                                        -1.8044474441773015e-20
  53                                        -7.905384086522615e-21
  54                                        4.43571136636957e-21
  55                                        -4.26410399497812e-22
  56                                        -3.9201017669371173e-22
  57                                        1.5273780513439943e-22
  58                                        1.0248495270493723e-23
  59                                        -2.1349078747714336e-23
  60                                        3.239139475160028e-24
  61                                        2.14218376229989e-24
  62                                        -8.234609419601019e-25
  63                                        -1.5246528296458095e-25
  64                                        1.378208282460639e-25
  65                                        2.1313112028339478e-27
  66                                        -2.012649651526484e-26
  67                                        1.995535662263358e-27
  68                                        2.7989958089840034e-27
  69                                        -5.534511845389627e-28
  70                                        -3.884995396159969e-28
  71                                        1.1213044345073594e-28
  72                                        5.566568152423741e-29
  73                                        -2.0454829298104996e-29
  74                                        -8.453813992712336e-30
  75                                        3.5657584334312916e-30
  76                                        1.3836538721256348e-30
  77                                        -6.0621678644513725e-31
  78                                        -2.4471980439893134e-31
  79                                        1.0068506409339983e-31
  80                                        4.623685555014869e-32)))
  81       (ae11cs
  82        (make-array 60
  83                    :element-type 'double-float
  84                    :initial-contents '(0.2026315064707889 -0.07365514099120313
  85                                        0.006390934911836192
  86                                        -6.079725270524792e-4
  87                                        -7.370649862017663e-5
  88                                        4.873285744945018e-5
  89                                        -2.383706484044829e-6
  90                                        -3.051861262856152e-6
  91                                        1.705033157256456e-7
  92                                        2.3834204527487747e-7
  93                                        1.0781772556163167e-8
  94                                        -1.7955692847399104e-8
  95                                        -4.128407234195046e-9
  96                                        6.862214858863197e-10
  97                                        5.313018312050636e-10
  98                                        7.87968802614907e-11
  99                                        -2.626176232935652e-11
 100                                        -1.5483687636308263e-11
 101                                        -2.581896237726139e-12
 102                                        5.954287919159107e-13
 103                                        4.645140038768153e-13
 104                                        1.155785502325586e-13
 105                                        -1.0475236870835799e-15
 106                                        -1.1896653502709005e-14
 107                                        -4.774907749026178e-15
 108                                        -8.107764961577278e-16
 109                                        1.3435569250031553e-16
 110                                        1.4134530022913106e-16
 111                                        4.9451592573953175e-17
 112                                        7.988404848008067e-18
 113                                        -1.400863218808981e-18
 114                                        -1.4814246958417373e-18
 115                                        -5.58261736460256e-19
 116                                        -1.1442074542191647e-19
 117                                        2.537182387956685e-21
 118                                        1.320532815480536e-20
 119                                        6.293026108158681e-21
 120                                        1.7688270424882712e-21
 121                                        2.3266187985146046e-22
 122                                        -6.780306081112523e-23
 123                                        -5.944087695967637e-23
 124                                        -2.3618214531184416e-23
 125                                        -6.0214499724601476e-24
 126                                        -6.55179064743483e-25
 127                                        2.9388755297497726e-25
 128                                        2.2601606200642114e-25
 129                                        8.953436924595863e-26
 130                                        2.4015923471098456e-26
 131                                        3.4118376888907176e-27
 132                                        -7.161707169463034e-28
 133                                        -7.562039065928173e-28
 134                                        -3.3774612157467327e-28
 135                                        -1.047932570330094e-28
 136                                        -2.1654550252170343e-29
 137                                        -7.529712574528827e-31
 138                                        1.9103179392798935e-30
 139                                        1.1492104966530338e-30
 140                                        4.389697058266175e-31
 141                                        1.2320883239205687e-31
 142                                        2.2220174457553174e-32)))
 143       (ae12cs
 144        (make-array 41
 145                    :element-type 'double-float
 146                    :initial-contents '(0.6362958979674704 -0.13081168675067634
 147                                        -0.008436741021305393
 148                                        0.0026568491531006686
 149                                        3.2822721781658134e-4
 150                                        -2.3783447771430248e-5
 151                                        -1.1439804308100055e-5
 152                                        -1.4405943433238338e-6
 153                                        5.241595665114883e-9
 154                                        3.8407306407844325e-8
 155                                        8.58802448602672e-9
 156                                        1.0219226625855004e-9
 157                                        2.1749132323289725e-11
 158                                        -2.2090238142623143e-11
 159                                        -6.3457533544928755e-12
 160                                        -1.083774656685766e-12
 161                                        -1.1909822872222587e-13
 162                                        -2.8438682389265592e-15
 163                                        2.508032702668677e-15
 164                                        7.872964152855985e-16
 165                                        1.5475066347785216e-16
 166                                        2.2575322831665076e-17
 167                                        2.223335286726661e-18
 168                                        1.6967819563544153e-20
 169                                        -5.760831625594768e-20
 170                                        -1.7591235774646877e-20
 171                                        -3.628605637510317e-21
 172                                        -5.923556979732899e-22
 173                                        -7.603038092631019e-23
 174                                        -6.254784352171177e-24
 175                                        2.548336075930765e-25
 176                                        2.5598615731739856e-25
 177                                        7.137623935789932e-26
 178                                        1.4703759939567568e-26
 179                                        2.5105524765386733e-27
 180                                        3.588666638779089e-28
 181                                        3.98860351567713e-29
 182                                        2.176367694735622e-30
 183                                        -4.614699848761894e-31
 184                                        -2.071351787748199e-31
 185                                        -5.189037856353437e-32)))
 186       (e11cs
 187        (make-array 29
 188                    :element-type 'double-float
 189                    :initial-contents '(-16.113461655571495 7.79407277874268
 190                                        -1.955405818863142 0.37337293866277943
 191                                        -0.05692503191092902
 192                                        0.0072110777696600915
 193                                        -7.810490144984159e-4
 194                                        7.388093356262168e-5
 195                                        -6.202861875808204e-6
 196                                        4.6816002303176734e-7
 197                                        -3.209288853329865e-8
 198                                        2.0151997487404535e-9
 199                                        -1.1673686816697794e-10
 200                                        6.276270667203995e-12
 201                                        -3.148154167227544e-13
 202                                        1.4799041744493474e-14
 203                                        -6.545709158397967e-16
 204                                        2.733687222313729e-17
 205                                        -1.0813524349754407e-18
 206                                        4.06283280404343e-20
 207                                        -1.4535539358960456e-21
 208                                        4.9632746181648634e-23
 209                                        -1.6208612696636044e-24
 210                                        5.072144803860742e-26
 211                                        -1.5235811133372208e-27
 212                                        4.400151125610362e-29
 213                                        -1.2236141945416232e-30
 214                                        3.2809216661066004e-32
 215                                        -8.493345226830644e-34)))
 216       (e12cs
 217        (make-array 25
 218                    :element-type 'double-float
 219                    :initial-contents '(-0.037390214792202794
 220                                        0.042723986062209576
 221                                        -0.13031820798497004 0.01441912402469889
 222                                        -0.0013461707805106802
 223                                        1.073102925306378e-4
 224                                        -7.429999516119436e-6
 225                                        4.537732569075371e-7
 226                                        -2.4764172113906014e-8
 227                                        1.2207658137459096e-9
 228                                        -5.485141480640924e-11
 229                                        2.263621421300788e-12
 230                                        -8.63589727169801e-14
 231                                        3.06291553669333e-15
 232                                        -1.0148571885594415e-16
 233                                        3.1548217403406988e-18
 234                                        -9.23604240769241e-20
 235                                        2.55504267970814e-21
 236                                        -6.699128056845668e-23
 237                                        1.6692540543538733e-24
 238                                        -3.9625492518437966e-26
 239                                        8.981358965985113e-28
 240                                        -1.9476336699301643e-29
 241                                        4.0483601902463e-31
 242                                        -8.079815676998451e-33)))
 243       (ae13cs
 244        (make-array 50
 245                    :element-type 'double-float
 246                    :initial-contents '(-0.6057732466406035 -0.1125352434836609
 247                                        0.01343226624790278
 248                                        -0.0019268451873811457
 249                                        3.091183377206032e-4
 250                                        -5.356413212961842e-5
 251                                        9.827812880247493e-6
 252                                        -1.8853689849165184e-6
 253                                        3.7494319356894736e-7
 254                                        -7.682345587055264e-8
 255                                        1.6143270567198776e-8
 256                                        -3.4668022114907356e-9
 257                                        7.587542091903628e-10
 258                                        -1.6886433329881412e-10
 259                                        3.8145706749552266e-11
 260                                        -8.733026632444629e-12
 261                                        2.023672864586796e-12
 262                                        -4.741328303955583e-13
 263                                        1.1221172048389864e-13
 264                                        -2.680422543484031e-14
 265                                        6.457851441771653e-15
 266                                        -1.5682760501666479e-15
 267                                        3.8367865399315405e-16
 268                                        -9.451717302757913e-17
 269                                        2.3434812288949573e-17
 270                                        -5.845866158021471e-18
 271                                        1.4666229867947778e-18
 272                                        -3.6993923476444474e-19
 273                                        9.379015993672124e-20
 274                                        -2.3893673221937873e-20
 275                                        6.115062462949761e-21
 276                                        -1.5718585327554025e-21
 277                                        4.0572387285585398e-22
 278                                        -1.0514026554738035e-22
 279                                        2.734966493063867e-23
 280                                        -7.14016040802058e-24
 281                                        1.870555243223508e-24
 282                                        -4.916746816687048e-25
 283                                        1.2964988119684032e-25
 284                                        -3.4292515688362866e-26
 285                                        9.097224164388703e-27
 286                                        -2.4202112314316855e-27
 287                                        6.4563612934639515e-28
 288                                        -1.7269132735340542e-28
 289                                        4.6308611659151503e-29
 290                                        -1.2448703637214132e-29
 291                                        3.354457409052068e-30
 292                                        -9.059886852107077e-31
 293                                        2.4524147051474238e-31
 294                                        -6.652817873355206e-32)))
 295       (ae14cs
 296        (make-array 64
 297                    :element-type 'double-float
 298                    :initial-contents '(-0.1892918000753017 -0.08648117855259871
 299                                        0.007224101543746595
 300                                        -8.097559457557386e-4
 301                                        1.0999134432661389e-4
 302                                        -1.7173329989377674e-5
 303                                        2.9856275144792833e-6
 304                                        -5.65964914577193e-7 1.15268083971414e-7
 305                                        -2.4950304402693382e-8
 306                                        5.692324201833754e-9
 307                                        -1.3599576648056003e-9
 308                                        3.3846628887608844e-10
 309                                        -8.737853904474682e-11
 310                                        2.33158866322266e-11
 311                                        -6.411481049213786e-12
 312                                        1.8122469802048165e-12
 313                                        -5.253831761558461e-13
 314                                        1.5592182725919257e-13
 315                                        -4.7291682970803986e-14
 316                                        1.4637618643932435e-14
 317                                        -4.617388988712924e-15
 318                                        1.4827103482893693e-15
 319                                        -4.841672496239229e-16
 320                                        1.6062155757002903e-16
 321                                        -5.408917538957171e-17
 322                                        1.847470159346898e-17
 323                                        -6.395830792759095e-18
 324                                        2.2427807216997594e-18
 325                                        -7.961369173983947e-19
 326                                        2.8593081115401974e-19
 327                                        -1.0384502447011372e-19
 328                                        3.8120406070979756e-20
 329                                        -1.4137954177172008e-20
 330                                        5.295367865182741e-21
 331                                        -2.002264245026826e-21
 332                                        7.640262751275196e-22
 333                                        -2.941119006868788e-22
 334                                        1.1418235390789271e-22
 335                                        -4.4693084759552986e-23
 336                                        1.7632624105717507e-23
 337                                        -7.009968187925902e-24
 338                                        2.807573556558379e-24
 339                                        -1.1325609449810865e-24
 340                                        4.600574684375018e-25
 341                                        -1.8814485989761335e-25
 342                                        7.744916111507731e-26
 343                                        -3.208512760585369e-26
 344                                        1.3374455429108399e-26
 345                                        -5.608671881802217e-27
 346                                        2.3658397165285374e-27
 347                                        -1.0036561950253053e-27
 348                                        4.281490878094161e-28
 349                                        -1.836345261815318e-28
 350                                        7.91779823134954e-29
 351                                        -3.4315423587422206e-29
 352                                        1.4947054938971032e-29
 353                                        -6.542620279865706e-30
 354                                        2.8775813951991712e-30
 355                                        -1.2715572117960247e-30
 356                                        5.644615555648722e-31
 357                                        -2.5169949942840953e-31
 358                                        1.1272598189275103e-31
 359                                        -5.069814875800461e-32)))
 360       (first$ nil))
 361   (declare (type (f2cl-lib:integer4) ntae10 ntae11 ntae12 nte11 nte12 ntae13
 362                                      ntae14)
 363            (type (double-float) xmax)
 364            (type (simple-array double-float (50)) ae10cs ae13cs)
 365            (type (simple-array double-float (60)) ae11cs)
 366            (type (simple-array double-float (41)) ae12cs)
 367            (type (simple-array double-float (29)) e11cs)
 368            (type (simple-array double-float (25)) e12cs)
 369            (type (simple-array double-float (64)) ae14cs)
 370            (type f2cl-lib:logical first$))
 371   (setq first$ f2cl-lib:%true%)
 372   (defun de1 (x)
 373     (declare (type (double-float) x))
 374     (prog ((xmaxt 0.0) (de1 0.0) (eta 0.0f0))
 375       (declare (type (single-float) eta) (type (double-float) de1 xmaxt))
 376       (cond
 377         (first$
 378          (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
 379          (setf ntae10 (initds ae10cs 50 eta))
 380          (setf ntae11 (initds ae11cs 60 eta))
 381          (setf ntae12 (initds ae12cs 41 eta))
 382          (setf nte11 (initds e11cs 29 eta))
 383          (setf nte12 (initds e12cs 25 eta))
 384          (setf ntae13 (initds ae13cs 50 eta))
 385          (setf ntae14 (initds ae14cs 64 eta))
 386          (setf xmaxt (- (f2cl-lib:flog (f2cl-lib:d1mach 1))))
 387          (setf xmax (- xmaxt (f2cl-lib:flog xmaxt)))))
 388       (setf first$ f2cl-lib:%false%)
 389       (if (> x -1.0) (go label50))
 390       (if (> x -32.0) (go label20))
 391       (setf de1
 392               (* (/ (exp (- x)) x)
 393                  (+ 1.0 (dcsevl (+ (/ 64.0 x) 1.0) ae10cs ntae10))))
 394       (go end_label)
 395      label20
 396       (if (> x -8.0) (go label30))
 397       (setf de1
 398               (* (/ (exp (- x)) x)
 399                  (+ 1.0 (dcsevl (/ (+ (/ 64.0 x) 5.0) 3.0) ae11cs ntae11))))
 400       (go end_label)
 401      label30
 402       (if (> x -4.0) (go label40))
 403       (setf de1
 404               (* (/ (exp (- x)) x)
 405                  (+ 1.0 (dcsevl (+ (/ 16.0 x) 3.0) ae12cs ntae12))))
 406       (go end_label)
 407      label40
 408       (setf de1
 409               (- (dcsevl (/ (+ (* 2.0 x) 5.0) 3.0) e11cs nte11)
 410                  (f2cl-lib:flog (- x))))
 411       (go end_label)
 412      label50
 413       (if (> x 1.0) (go label60))
 414       (if (= x 0.0) (xermsg "SLATEC" "DE1" "X IS 0" 2 2))
 415       (setf de1
 416               (+ (- -0.6875 (f2cl-lib:flog (abs x))) x (dcsevl x e12cs nte12)))
 417       (go end_label)
 418      label60
 419       (if (> x 4.0) (go label70))
 420       (setf de1
 421               (* (/ (exp (- x)) x)
 422                  (+ 1.0 (dcsevl (/ (- (/ 8.0 x) 5.0) 3.0) ae13cs ntae13))))
 423       (go end_label)
 424      label70
 425       (if (> x xmax) (go label80))
 426       (setf de1
 427               (* (/ (exp (- x)) x)
 428                  (+ 1.0 (dcsevl (- (/ 8.0 x) 1.0) ae14cs ntae14))))
 429       (go end_label)
 430      label80
 431       (xermsg "SLATEC" "DE1" "X SO BIG E1 UNDERFLOWS" 1 1)
 432       (setf de1 0.0)
 433       (go end_label)
 434      end_label
 435       (return (values de1 nil)))))
 436
 437 (in-package #:cl-user)
 438 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 439 (eval-when (:load-toplevel :compile-toplevel :execute)
 440   (setf (gethash 'fortran-to-lisp::de1 fortran-to-lisp::*f2cl-function-info*)
 441           (fortran-to-lisp::make-f2cl-finfo :arg-types '((double-float))
 442                                             :return-values '(nil)
 443                                             :calls '(fortran-to-lisp::xermsg
 444                                                      fortran-to-lisp::dcsevl
 445                                                      fortran-to-lisp::initds
 446                                                      fortran-to-lisp::d1mach))))
 447