src/numerical/slatec/d9aimp.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 ((nam20 0)
  21       (nath0 0)
  22       (nam21 0)
  23       (nath1 0)
  24       (nam22 0)
  25       (nath2 0)
  26       (xsml 0.0)
  27       (am20cs
  28        (make-array 57
  29                    :element-type 'double-float
  30                    :initial-contents '(0.010871674908656186
  31                                        3.6948922898266353e-4
  32                                        4.4068010048468954e-6
  33                                        1.4368676236191115e-7
  34                                        8.242755523900783e-9
  35                                        6.844267588936616e-10
  36                                        7.395666972827393e-11
  37                                        9.74595633696825e-12
  38                                        1.5007688582940578e-12
  39                                        2.6214791022152763e-13
  40                                        5.083541113764872e-14
  41                                        1.0768475335881144e-14
  42                                        2.460912866184334e-15
  43                                        6.007863803586564e-16
  44                                        1.5544915610238807e-16
  45                                        4.235351250355766e-17
  46                                        1.2086216628929984e-17
  47                                        3.596096512146583e-18
  48                                        1.1113421838639565e-18
  49                                        3.555595324323666e-19
  50                                        1.174330216001393e-19
  51                                        3.993974546610776e-20
  52                                        1.395766715289163e-20
  53                                        5.0024005530923605e-21
  54                                        1.8355276095813267e-21
  55                                        6.884909981792028e-22
  56                                        2.63631035611417e-22
  57                                        1.0292489023733836e-22
  58                                        4.0924696667159487e-23
  59                                        1.6555857340673466e-23
  60                                        6.807974670630334e-24
  61                                        2.8432655993407982e-24
  62                                        1.2050739834896525e-24
  63                                        5.179612432875052e-25
  64                                        2.256226134275628e-25
  65                                        9.954188011477451e-26
  66                                        4.445516963973424e-26
  67                                        2.008651954615011e-26
  68                                        9.177863441517751e-27
  69                                        4.238729581055893e-27
  70                                        1.9778927200784608e-27
  71                                        9.321163512846207e-28
  72                                        4.434821332499181e-28
  73                                        2.129456723655739e-28
  74                                        1.0315856965107598e-28
  75                                        5.040237730225912e-29
  76                                        2.4830130457015594e-29
  77                                        1.2330178312856219e-29
  78                                        6.1703344992052174e-30
  79                                        3.110926174159189e-30
  80                                        1.5798308520170617e-30
  81                                        8.079319875382835e-31
  82                                        4.159973941386676e-31
  83                                        2.156109340977169e-31
  84                                        1.1246885726586918e-31
  85                                        5.90331560632838e-32
  86                                        3.1173566769292857e-32)))
  87       (ath0cs
  88        (make-array 53
  89                    :element-type 'double-float
  90                    :initial-contents '(-0.08172601764161634
  91                                        -8.004012824788273e-4
  92                                        -3.186525268782113e-6
  93                                        -6.68838826647751e-8
  94                                        -2.9317592849945644e-9
  95                                        -2.0112637608836216e-10
  96                                        -1.8775226780559733e-11
  97                                        -2.1996371377046013e-12
  98                                        -3.0716166825922727e-13
  99                                        -4.9361405536734185e-14
 100                                        -8.902833722583661e-15
 101                                        -1.7689877646152725e-15
 102                                        -3.817868689032277e-16
 103                                        -8.851159014819948e-17
 104                                        -2.184818181414366e-17
 105                                        -5.700849046986453e-18
 106                                        -1.5631211221778754e-18
 107                                        -4.481437996768995e-19
 108                                        -1.337794883736188e-19
 109                                        -4.1433400368741143e-20
 110                                        -1.327263385718805e-20
 111                                        -4.385728589128441e-21
 112                                        -1.4913606959528181e-21
 113                                        -5.2081047386307115e-22
 114                                        -1.864382222390499e-22
 115                                        -6.830263751167969e-23
 116                                        -2.5571170580293295e-23
 117                                        -9.7701586402543e-24
 118                                        -3.805161433416679e-24
 119                                        -1.5090227507370542e-24
 120                                        -6.087551341242425e-25
 121                                        -2.4958795138097113e-25
 122                                        -1.0391576545819209e-25
 123                                        -4.3902359139768467e-26
 124                                        -1.8807906784479903e-26
 125                                        -8.165070764199463e-27
 126                                        -3.589944503749751e-27
 127                                        -1.5976581266321329e-27
 128                                        -7.193250175703824e-28
 129                                        -3.2749430127278565e-28
 130                                        -1.5070424457836906e-28
 131                                        -7.006624198319905e-29
 132                                        -3.289907402983718e-29
 133                                        -1.5595180843651466e-29
 134                                        -7.460690508208254e-30
 135                                        -3.600877034824662e-30
 136                                        -1.7528514374737722e-30
 137                                        -8.603275775188512e-31
 138                                        -4.256432603226946e-31
 139                                        -2.1221618650442627e-31
 140                                        -1.065996156704879e-31
 141                                        -5.393568608816949e-32
 142                                        -2.748174851043955e-32)))
 143       (am21cs
 144        (make-array 60
 145                    :element-type 'double-float
 146                    :initial-contents '(0.005927902667213096
 147                                        0.002005694053931652
 148                                        9.110818502622758e-5
 149                                        8.498943063720471e-6
 150                                        1.1329790897691307e-6
 151                                        1.875179461006665e-7
 152                                        3.593065190182458e-8
 153                                        7.657577140716838e-9
 154                                        1.7699996716803918e-9
 155                                        4.362595556545989e-10
 156                                        1.1329164133785322e-10
 157                                        3.072576909824192e-11
 158                                        8.64482416482201e-12
 159                                        2.510152500609244e-12
 160                                        7.491024967644404e-13
 161                                        2.289969284879941e-13
 162                                        7.151136589279877e-14
 163                                        2.2760792495956686e-14
 164                                        7.369421427608866e-15
 165                                        2.423286752678275e-15
 166                                        8.081537745482399e-16
 167                                        2.730080798043561e-16
 168                                        9.332360708913853e-17
 169                                        3.2250809968108464e-17
 170                                        1.1258193234644454e-17
 171                                        3.966994639869388e-18
 172                                        1.410065679443195e-18
 173                                        5.053020865378512e-19
 174                                        1.8246152321594515e-19
 175                                        6.635845682621305e-20
 176                                        2.4296373163127618e-20
 177                                        8.952389151236878e-21
 178                                        3.318452893500508e-21
 179                                        1.2370619618865832e-21
 180                                        4.636366770123908e-22
 181                                        1.7465313594776447e-22
 182                                        6.611168102349912e-23
 183                                        2.514099189940725e-23
 184                                        9.602749955717325e-24
 185                                        3.683249522892964e-24
 186                                        1.4184313826915914e-24
 187                                        5.483426742769359e-25
 188                                        2.127610546231188e-25
 189                                        8.284437008494186e-26
 190                                        3.23670563926127e-26
 191                                        1.2686888296328606e-26
 192                                        4.988438189921216e-27
 193                                        1.967345844676494e-27
 194                                        7.781359710203269e-28
 195                                        3.0863394149891115e-28
 196                                        1.227446470454531e-28
 197                                        4.894312791342922e-29
 198                                        1.9564687980290983e-29
 199                                        7.839889529224262e-30
 200                                        3.1489691400248424e-30
 201                                        1.2676976313725068e-30
 202                                        5.114706919069002e-31
 203                                        2.0680170979553875e-31
 204                                        8.37891344768519e-32
 205                                        3.401689919714898e-32)))
 206       (ath1cs
 207        (make-array 58
 208                    :element-type 'double-float
 209                    :initial-contents '(-0.06972849916208884
 210                                        -0.005108722790650045
 211                                        -8.644335996989756e-5
 212                                        -5.604720044235264e-6
 213                                        -6.045735125623897e-7
 214                                        -8.639802632488334e-8
 215                                        -1.4808094843099271e-8
 216                                        -2.885809334577236e-9
 217                                        -6.191631975665699e-10
 218                                        -1.4319928088609578e-10
 219                                        -3.5181411021372145e-11
 220                                        -9.084761919955078e-12
 221                                        -2.4461716726885985e-12
 222                                        -6.826083203213446e-13
 223                                        -1.9645799311949403e-13
 224                                        -5.808933227139693e-14
 225                                        -1.759042249527442e-14
 226                                        -5.440902932714896e-15
 227                                        -1.7152474074868068e-15
 228                                        -5.500929233576992e-16
 229                                        -1.7918782877393173e-16
 230                                        -5.920372520086694e-17
 231                                        -1.981713027876484e-17
 232                                        -6.713232347016352e-18
 233                                        -2.299450243658281e-18
 234                                        -7.957300928236376e-19
 235                                        -2.779994027291784e-19
 236                                        -9.798924361326986e-20
 237                                        -3.4827170060615747e-20
 238                                        -1.2474891225585991e-20
 239                                        -4.501210041478228e-21
 240                                        -1.6353462440133521e-21
 241                                        -5.980102897780336e-22
 242                                        -2.2002462862861235e-22
 243                                        -8.142463073515086e-23
 244                                        -3.0299247736600425e-23
 245                                        -1.1333900985746235e-23
 246                                        -4.260766024749296e-24
 247                                        -1.6093633962781897e-24
 248                                        -6.106377190825026e-25
 249                                        -2.326954318021694e-25
 250                                        -8.903987877472253e-26
 251                                        -3.420558530005675e-26
 252                                        -1.3190267152572728e-26
 253                                        -5.104899493612043e-27
 254                                        -1.9825994784745476e-27
 255                                        -7.7257023568808305e-28
 256                                        -3.02023473366468e-28
 257                                        -1.18437973907417e-28
 258                                        -4.6584302279223085e-29
 259                                        -1.8375541881003845e-29
 260                                        -7.26856689442799e-30
 261                                        -2.882863120391468e-30
 262                                        -1.1463746294599063e-30
 263                                        -4.570031437748533e-31
 264                                        -1.826276602045346e-31
 265                                        -7.315349993385251e-32
 266                                        -2.9369255999714296e-32)))
 267       (am22cs
 268        (make-array 74
 269                    :element-type 'double-float
 270                    :initial-contents '(-0.015628444806253413
 271                                        0.007783364452396813
 272                                        8.670577704771895e-4
 273                                        1.5696627315611372e-4
 274                                        3.563962571432865e-5
 275                                        9.245983354250432e-6
 276                                        2.621101618504224e-6
 277                                        7.918822165160125e-7
 278                                        2.5104152792101184e-7
 279                                        8.265223206654078e-8
 280                                        2.8057116628130525e-8
 281                                        9.768210904846808e-9
 282                                        3.4740792322771035e-9
 283                                        1.2582813216983691e-9
 284                                        4.629882606418953e-10
 285                                        1.7272825881360407e-10
 286                                        6.523192001311541e-11
 287                                        2.4904716852098205e-11
 288                                        9.601568205537659e-12
 289                                        3.734480020677269e-12
 290                                        1.464175650320534e-12
 291                                        5.782654711685129e-13
 292                                        2.299154072447061e-13
 293                                        9.197807112319973e-14
 294                                        3.700600688130901e-14
 295                                        1.49675761698673e-14
 296                                        6.083611949384611e-15
 297                                        2.4840408711512138e-15
 298                                        1.0186247652676908e-15
 299                                        4.19383856352754e-16
 300                                        1.7331890176293075e-16
 301                                        7.188219023885086e-17
 302                                        2.991236335984036e-17
 303                                        1.2486899043323863e-17
 304                                        5.2282934460948366e-18
 305                                        2.195329617247134e-18
 306                                        9.242983252297773e-19
 307                                        3.901577082360914e-19
 308                                        1.6509389269386372e-19
 309                                        7.002218157159944e-20
 310                                        2.976518336167869e-20
 311                                        1.2679653908690207e-20
 312                                        5.412434006970776e-21
 313                                        2.3148735021815524e-21
 314                                        9.919202883865666e-22
 315                                        4.258030153237324e-22
 316                                        1.831018429730245e-22
 317                                        7.886787123110753e-23
 318                                        3.402546073862299e-23
 319                                        1.4702088140571253e-23
 320                                        6.36211018324917e-24
 321                                        2.7570705068098073e-24
 322                                        1.1964585809010406e-24
 323                                        5.199125457292422e-25
 324                                        2.2621767484710446e-25
 325                                        9.855261137544318e-26
 326                                        4.2987063033250873e-26
 327                                        1.8772364166158064e-26
 328                                        8.207219417728422e-27
 329                                        3.592146656046155e-27
 330                                        1.5739059461277332e-27
 331                                        6.903297810393338e-28
 332                                        3.030920790789685e-28
 333                                        1.3320493416048123e-28
 334                                        5.859788368515235e-29
 335                                        2.580168684894878e-29
 336                                        1.1371243363728367e-29
 337                                        5.015925572260685e-30
 338                                        2.214458293955094e-30
 339                                        9.784702838865072e-31
 340                                        4.326954149341802e-31
 341                                        1.9149728819399457e-31
 342                                        8.481646224023924e-32
 343                                        3.759470651739559e-32)))
 344       (ath2cs
 345        (make-array 72
 346                    :element-type 'double-float
 347                    :initial-contents '(0.004405273458718779
 348                                        -0.030429194523184547
 349                                        -0.0013856532837717938
 350                                        -1.8044439089549524e-4
 351                                        -3.3808471083273084e-5
 352                                        -7.678183535229024e-6
 353                                        -1.967839443716035e-6
 354                                        -5.4837271158777e-7
 355                                        -1.6254615505326126e-7
 356                                        -5.053049981268895e-8
 357                                        -1.631580701124067e-8
 358                                        -5.4342041123485176e-9
 359                                        -1.8573985564099003e-9
 360                                        -6.489512033326109e-10
 361                                        -2.3105948858009446e-10
 362                                        -8.363282183204412e-11
 363                                        -3.071196844890191e-11
 364                                        -1.1423671424327168e-11
 365                                        -4.2981160663458034e-12
 366                                        -1.6338986995967155e-12
 367                                        -6.269328620016619e-13
 368                                        -2.4260526948162576e-13
 369                                        -9.46119832162404e-14
 370                                        -3.7160603134115045e-14
 371                                        -1.4691556840975268e-14
 372                                        -5.843694726140912e-15
 373                                        -2.337502595591951e-15
 374                                        -9.399231371171434e-16
 375                                        -3.7980146693728945e-16
 376                                        -1.5417310439849726e-16
 377                                        -6.285287079535307e-17
 378                                        -2.5727318128114555e-17
 379                                        -1.0570981193540178e-17
 380                                        -4.359080267402697e-18
 381                                        -1.803634315959978e-18
 382                                        -7.486838064380537e-19
 383                                        -3.117261367347605e-19
 384                                        -1.3016879809277009e-19
 385                                        -5.450527587519523e-20
 386                                        -2.288293490114232e-20
 387                                        -9.631059503829539e-21
 388                                        -4.063281001524614e-21
 389                                        -1.718203980908027e-21
 390                                        -7.281574619892536e-22
 391                                        -3.092352652680643e-22
 392                                        -1.3159178559654404e-22
 393                                        -5.610606786087056e-23
 394                                        -2.396621894086355e-23
 395                                        -1.0255743323905812e-23
 396                                        -4.3962641381436564e-24
 397                                        -1.8876529983725773e-24
 398                                        -8.118140359576808e-25
 399                                        -3.496734274366287e-25
 400                                        -1.5084029251568733e-25
 401                                        -6.516268284778671e-26
 402                                        -2.8189457975292075e-26
 403                                        -1.2211275965122627e-26
 404                                        -5.2966743411698674e-27
 405                                        -2.3003592707736733e-27
 406                                        -1.0002794823553675e-27
 407                                        -4.354760404180879e-28
 408                                        -1.8980561347414776e-28
 409                                        -8.282111868712974e-29
 410                                        -3.617815493066569e-29
 411                                        -1.5820188961780036e-29
 412                                        -6.92506859780227e-30
 413                                        -3.0343902397786293e-30
 414                                        -1.3308895681667253e-30
 415                                        -5.84284852217309e-31
 416                                        -2.5674884232383028e-31
 417                                        -1.1292323222688822e-31
 418                                        -4.970947029753337e-32)))
 419       (pi4 0.7853981633974483)
 420       (first$ nil))
 421   (declare (type (f2cl-lib:integer4) nam20 nath0 nam21 nath1 nam22 nath2)
 422            (type (double-float) xsml pi4)
 423            (type (simple-array double-float (57)) am20cs)
 424            (type (simple-array double-float (53)) ath0cs)
 425            (type (simple-array double-float (60)) am21cs)
 426            (type (simple-array double-float (58)) ath1cs)
 427            (type (simple-array double-float (74)) am22cs)
 428            (type (simple-array double-float (72)) ath2cs)
 429            (type f2cl-lib:logical first$))
 430   (setq first$ f2cl-lib:%true%)
 431   (defun d9aimp (x ampl theta)
 432     (declare (type (double-float) theta ampl x))
 433     (prog ((sqrtx 0.0) (z 0.0) (eta 0.0f0))
 434       (declare (type (single-float) eta) (type (double-float) z sqrtx))
 435       (cond
 436         (first$
 437          (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
 438          (setf nam20 (initds am20cs 57 eta))
 439          (setf nath0 (initds ath0cs 53 eta))
 440          (setf nam21 (initds am21cs 60 eta))
 441          (setf nath1 (initds ath1cs 58 eta))
 442          (setf nam22 (initds am22cs 74 eta))
 443          (setf nath2 (initds ath2cs 72 eta))
 444          (setf xsml (/ -1.0 (expt (f2cl-lib:d1mach 3) 0.3333)))))
 445       (setf first$ f2cl-lib:%false%)
 446       (if (>= x -4.0) (go label20))
 447       (setf z 1.0)
 448       (if (> x xsml) (setf z (+ (/ 128.0 (expt x 3)) 1.0)))
 449       (setf ampl (+ 0.3125 (dcsevl z am20cs nam20)))
 450       (setf theta (- (dcsevl z ath0cs nath0) 0.625))
 451       (go label40)
 452      label20
 453       (if (>= x -2.0) (go label30))
 454       (setf z (/ (+ (/ 128.0 (expt x 3)) 9.0) 7.0))
 455       (setf ampl (+ 0.3125 (dcsevl z am21cs nam21)))
 456       (setf theta (- (dcsevl z ath1cs nath1) 0.625))
 457       (go label40)
 458      label30
 459       (if (>= x -1.0) (xermsg "SLATEC" "D9AIMP" "X MUST BE LE -1.0" 1 2))
 460       (setf z (/ (+ (/ 16.0 (expt x 3)) 9.0) 7.0))
 461       (setf ampl (+ 0.3125 (dcsevl z am22cs nam22)))
 462       (setf theta (- (dcsevl z ath2cs nath2) 0.625))
 463      label40
 464       (setf sqrtx (f2cl-lib:fsqrt (- x)))
 465       (setf ampl (f2cl-lib:fsqrt (/ ampl sqrtx)))
 466       (setf theta (+ pi4 (* (- x) sqrtx theta)))
 467       (go end_label)
 468      end_label
 469       (return (values nil ampl theta)))))
 470
 471 (in-package #:cl-user)
 472 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 473 (eval-when (:load-toplevel :compile-toplevel :execute)
 474   (setf (gethash 'fortran-to-lisp::d9aimp
 475                  fortran-to-lisp::*f2cl-function-info*)
 476           (fortran-to-lisp::make-f2cl-finfo
 477            :arg-types '((double-float) (double-float) (double-float))
 478            :return-values '(nil fortran-to-lisp::ampl fortran-to-lisp::theta)
 479            :calls '(fortran-to-lisp::xermsg fortran-to-lisp::dcsevl
 480                     fortran-to-lisp::initds fortran-to-lisp::d1mach))))
 481