src/numerical/slatec/dasyjy.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 ':array)
  14 ;;;           (:array-slicing nil) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package :slatec)
  18
  19
  20 (let ((tols -6.90775527898214)
  21       (con1 0.666666666666667)
  22       (con2 0.333333333333333)
  23       (con548 0.104166666666667)
  24       (ar
  25        (make-array 8
  26                    :element-type 'double-float
  27                    :initial-contents '(0.0835503472222222 0.128226574556327
  28                                        0.29184902646414 0.881627267443758
  29                                        3.32140828186277 14.9957629868626
  30                                        78.9230130115865 474.451538868264)))
  31       (br
  32        (make-array 10
  33                    :element-type 'double-float
  34                    :initial-contents '(-0.145833333333333 -0.0987413194444444
  35                                        -0.143312053915895 -0.317227202678414
  36                                        -0.94242914795712 -3.51120304082635
  37                                        -15.727263620368 -82.2814390971859
  38                                        -492.355370523671 -3316.21856854797)))
  39       (c
  40        (make-array 65
  41                    :element-type 'double-float
  42                    :initial-contents '(-0.208333333333333 0.125
  43                                        0.334201388888889 -0.401041666666667
  44                                        0.0703125 -1.02581259645062
  45                                        1.84646267361111 -0.8912109375
  46                                        0.0732421875 4.66958442342625
  47                                        -11.207002616223 8.78912353515625
  48                                        -2.3640869140625 0.112152099609375
  49                                        -28.2120725582002 84.6362176746007
  50                                        -91.81824154324 42.5349987453885
  51                                        -7.36879435947963 0.227108001708984
  52                                        212.570130039217 -765.252468141182
  53                                        1059.990452528 -699.579627376133
  54                                        218.190511744212 -26.4914304869516
  55                                        0.572501420974731 -1919.45766231841
  56                                        8061.72218173731 -13586.5500064341
  57                                        11655.3933368645 -5305.6469786134
  58                                        1200.90291321635 -108.090919788395
  59                                        1.72772750258446 20204.2913309661
  60                                        -96980.5983886375 192547.001232532
  61                                        -203400.177280416 122200.464983017
  62                                        -41192.6549688976 7109.51430248936
  63                                        -493.915304773088 6.07404200127348
  64                                        -242919.187900551 1311763.61466298
  65                                        -2998015.91853811 3763271.2976564
  66                                        -2813563.22658653 1268365.27332162
  67                                        -331645.172484564 45218.7689813627
  68                                        -2499.83048181121 24.3805296995561
  69                                        3284469.85307204 -1.97068191184322e7
  70                                        5.09526024926646e7 -7.41051482115327e7
  71                                        6.6344512274729e7 -3.75671766607634e7
  72                                        1.32887671664218e7 -2785618.12808645
  73                                        308186.404612662 -13886.089753717
  74                                        110.017140269247)))
  75       (alfa
  76        (make-array 104
  77                    :element-type 'double-float
  78                    :initial-contents '(-0.00444444444444444
  79                                        -9.22077922077922e-4
  80                                        -8.84892884892885e-5 1.6592768783245e-4
  81                                        2.46691372741793e-4 2.65995589346255e-4
  82                                        2.61824297061501e-4 2.48730437344656e-4
  83                                        2.32721040083232e-4 2.16362485712365e-4
  84                                        2.00738858762752e-4 1.86267636637545e-4
  85                                        1.73060775917876e-4 1.61091705929016e-4
  86                                        1.50274774160908e-4 1.4050349739127e-4
  87                                        1.31668816545923e-4 1.23667445598253e-4
  88                                        1.16405271474738e-4 1.09798298372713e-4
  89                                        1.03772410422993e-4 9.82626078369363e-5
  90                                        9.32120517249503e-5 8.85710852478712e-5
  91                                        8.429631057157e-5 8.03497548407791e-5
  92                                        6.93735541354589e-4 2.32241745182922e-4
  93                                        -1.41986273556691e-5
  94                                        -1.16444931672049e-4
  95                                        -1.50803558053049e-4
  96                                        -1.55121924918096e-4
  97                                        -1.46809756646466e-4
  98                                        -1.33815503867491e-4
  99                                        -1.19744975684254e-4
 100                                        -1.06184319207974e-4
 101                                        -9.37699549891194e-5
 102                                        -8.26923045588193e-5
 103                                        -7.29374348155221e-5
 104                                        -6.44042357721016e-5
 105                                        -5.69611566009369e-5
 106                                        -5.04731044303562e-5
 107                                        -4.48134868008883e-5
 108                                        -3.98688727717599e-5
 109                                        -3.55400532972042e-5
 110                                        -3.17414256609022e-5
 111                                        -2.83996793904175e-5
 112                                        -2.54522720634871e-5
 113                                        -2.28459297164725e-5
 114                                        -2.05352753106481e-5
 115                                        -1.84816217627666e-5
 116                                        -1.66519330021394e-5
 117                                        -3.54211971457744e-4
 118                                        -1.56161263945159e-4 3.04465503594936e-5
 119                                        1.30198655773243e-4 1.67471106699712e-4
 120                                        1.70222587683593e-4 1.56501427608595e-4
 121                                        1.36339170977445e-4 1.14886692029825e-4
 122                                        9.45869093034688e-5 7.64498419250898e-5
 123                                        6.07570334965197e-5 4.74394299290509e-5
 124                                        3.62757512005344e-5 2.69939714979225e-5
 125                                        1.93210938247939e-5 1.30056674793963e-5
 126                                        7.82620866744497e-6 3.59257485819352e-6
 127                                        1.44040049814252e-7 -2.65396769697939e-6
 128                                        -4.91346867098486e-6
 129                                        -6.72739296091248e-6
 130                                        -8.17269379678658e-6
 131                                        -9.31304715093561e-6
 132                                        -1.02011418798016e-5 3.78194199201773e-4
 133                                        2.02471952761816e-4 -6.37938506318862e-5
 134                                        -2.38598230603006e-4
 135                                        -3.10916256027362e-4
 136                                        -3.13680115247576e-4
 137                                        -2.78950273791323e-4
 138                                        -2.28564082619141e-4
 139                                        -1.75245280340847e-4 -1.2554406306069e-4
 140                                        -8.22982872820208e-5
 141                                        -4.62860730588116e-5
 142                                        -1.72334302366962e-5 5.60690482304602e-6
 143                                        2.31395443148287e-5 3.62642745856794e-5
 144                                        4.58006124490189e-5 5.24595294959114e-5
 145                                        5.68396208545815e-5 5.94349820393104e-5
 146                                        6.06478527578422e-5 6.08023907788436e-5
 147                                        6.0157789453946e-5 5.89199657344698e-5
 148                                        5.72515823777593e-5
 149                                        5.52804375585853e-5)))
 150       (beta
 151        (make-array 130
 152                    :element-type 'double-float
 153                    :initial-contents '(0.0179988721413553 0.00559964911064388
 154                                        0.00288501402231133 0.00180096606761054
 155                                        0.00124753110589199 9.22878876572938e-4
 156                                        7.14430421727287e-4 5.71787281789705e-4
 157                                        4.69431007606482e-4 3.93232835462917e-4
 158                                        3.34818889318298e-4 2.88952148495752e-4
 159                                        2.52211615549573e-4 2.22280580798883e-4
 160                                        1.97541838033063e-4 1.76836855019718e-4
 161                                        1.59316899661821e-4 1.44347930197334e-4
 162                                        1.31448068119965e-4 1.20245444949303e-4
 163                                        1.10449144504599e-4 1.01828770740567e-4
 164                                        9.41998224204238e-5 8.74130545753834e-5
 165                                        8.13466262162801e-5 7.59002269646219e-5
 166                                        -0.00149282953213429
 167                                        -8.78204709546389e-4
 168                                        -5.02916549572035e-4
 169                                        -2.94822138512746e-4
 170                                        -1.75463996970783e-4
 171                                        -1.04008550460816e-4
 172                                        -5.96141953046458e-5
 173                                        -3.12038929076098e-5 -1.2608973598023e-5
 174                                        -2.4289260857573e-7 8.05996165414274e-6
 175                                        1.36507009262147e-5 1.73964125472926e-5
 176                                        1.98672978842134e-5 2.14463263790823e-5
 177                                        2.23954659232457e-5 2.28967783814713e-5
 178                                        2.30785389811178e-5 2.30321976080909e-5
 179                                        2.28236073720349e-5 2.25005881105292e-5
 180                                        2.20981015361991e-5 2.16418427448104e-5
 181                                        2.11507649256221e-5 2.06388749782171e-5
 182                                        2.01165241997082e-5 5.52213076721293e-4
 183                                        4.47932581552385e-4 2.79520653992021e-4
 184                                        1.52468156198447e-4 6.93271105657044e-5
 185                                        1.76258683069991e-5 -1.35744996343269e-5
 186                                        -3.17972413350427e-5
 187                                        -4.18861861696693e-5
 188                                        -4.69004889379141e-5
 189                                        -4.87665447413787e-5
 190                                        -4.87010031186735e-5
 191                                        -4.74755620890087e-5
 192                                        -4.55813058138628e-5
 193                                        -4.33309644511266e-5 -4.0923019315775e-5
 194                                        -3.84822638603221e-5
 195                                        -3.60857167535411e-5
 196                                        -3.37793306123367e-5 -3.1588856077211e-5
 197                                        -2.95269561750807e-5
 198                                        -2.75978914828336e-5
 199                                        -2.58006174666884e-5 -2.4130835676128e-5
 200                                        -2.25823509518346e-5
 201                                        -2.11479656768913e-5 -4.7461779655996e-4
 202                                        -4.77864567147321e-4
 203                                        -3.20390228067038e-4
 204                                        -1.61105016119962e-4
 205                                        -4.25778101285435e-5 3.44571294294968e-5
 206                                        7.97092684075675e-5 1.03138236708272e-4
 207                                        1.12466775262204e-4 1.13103642108481e-4
 208                                        1.08651634848774e-4 1.01437951597662e-4
 209                                        9.29298396593364e-5 8.4029313301609e-5
 210                                        7.52727991349134e-5 6.69632521975731e-5
 211                                        5.92564547323195e-5 5.22169308826976e-5
 212                                        4.58539485165361e-5 4.01445513891487e-5
 213                                        3.50481730031328e-5 3.05157995034347e-5
 214                                        2.64956119950516e-5 2.29363633690998e-5
 215                                        1.97893056664022e-5 1.70091984636413e-5
 216                                        7.36465810572578e-4 8.72790805146194e-4
 217                                        6.22614862573135e-4 2.85998154194304e-4
 218                                        3.84737672879366e-6 -1.87906003636972e-4
 219                                        -2.97603646594555e-4
 220                                        -3.45998126832656e-4
 221                                        -3.53382470916038e-4
 222                                        -3.35715635775049e-4 -3.0432112478904e-4
 223                                        -2.66722723047613e-4 -2.2765421412282e-4
 224                                        -1.89922611854562e-4
 225                                        -1.55058918599094e-4
 226                                        -1.23778240761874e-4
 227                                        -9.62926147717644e-5
 228                                        -7.25178327714425e-5
 229                                        -5.22070028895634e-5
 230                                        -3.50347750511901e-5
 231                                        -2.06489761035552e-5
 232                                        -8.70106096849767e-6 1.136986866751e-6
 233                                        9.16426474122779e-6 1.56477785428873e-5
 234                                        2.08223629482467e-5)))
 235       (gama
 236        (make-array 26
 237                    :element-type 'double-float
 238                    :initial-contents '(0.629960524947437 0.251984209978975
 239                                        0.154790300415656 0.110713062416159
 240                                        0.0857309395527395 0.0697161316958684
 241                                        0.0586085671893714 0.0504698873536311
 242                                        0.0442600580689155 0.039372066154351
 243                                        0.0354283195924455 0.0321818857502098
 244                                        0.0294646240791158 0.0271581677112934
 245                                        0.0251768272973862 0.0234570755306079
 246                                        0.0219508390134907 0.0206210828235646
 247                                        0.0194388240897881 0.0183810633800683
 248                                        0.0174293213231963 0.0165685837786612
 249                                        0.0157865285987918 0.0150729501494096
 250                                        0.0144193250839955 0.0138184805735342))))
 251   (declare (type (double-float) tols con1 con2 con548)
 252            (type (array double-float (8)) ar)
 253            (type (array double-float (10)) br)
 254            (type (array double-float (65)) c)
 255            (type (array double-float (104)) alfa)
 256            (type (array double-float (130)) beta)
 257            (type (array double-float (26)) gama))
 258   (defun dasyjy (funjy x fnu flgjy in y wk iflw)
 259     (declare (type (array double-float (*)) wk y)
 260              (type (f2cl-lib:integer4) iflw in)
 261              (type (double-float) flgjy fnu x))
 262     (f2cl-lib:with-multi-array-data
 263         ((y double-float y-%data% y-%offset%)
 264          (wk double-float wk-%data% wk-%offset%))
 265       (prog ((cr (make-array 10 :element-type 'double-float))
 266              (dr (make-array 10 :element-type 'double-float))
 267              (kmax (make-array 5 :element-type 'f2cl-lib:integer4))
 268              (upol (make-array 10 :element-type 'double-float)) (abw2 0.0)
 269              (akm 0.0) (ap 0.0) (asum 0.0) (az 0.0) (bsum 0.0) (crz32 0.0)
 270              (dfi 0.0) (elim 0.0) (fi 0.0) (fn 0.0) (fn2 0.0) (phi 0.0)
 271              (rcz 0.0) (rden 0.0) (relb 0.0) (rfn2 0.0) (rtz 0.0) (rzden 0.0)
 272              (sa 0.0) (sb 0.0) (suma 0.0) (sumb 0.0) (s1 0.0) (ta 0.0)
 273              (tau 0.0) (tb 0.0) (tfn 0.0) (tol 0.0) (t2 0.0) (xx 0.0) (z 0.0)
 274              (z32 0.0) (i 0) (j 0) (jn 0) (jr 0) (ju 0) (k 0) (kb 0) (klast 0)
 275              (kp1 0) (ks 0) (ksp1 0) (kstemp 0) (l 0) (lr 0) (lrp1 0) (iseta 0)
 276              (isetb 0))
 277         (declare (type (array f2cl-lib:integer4 (5)) kmax)
 278                  (type (f2cl-lib:integer4) isetb iseta lrp1 lr l kstemp ksp1 ks
 279                                            kp1 klast kb k ju jr jn j i)
 280                  (type (array double-float (10)) upol dr cr)
 281                  (type (double-float) z32 z xx t2 tol tfn tb tau ta s1 sumb
 282                                       suma sb sa rzden rtz rfn2 relb rden rcz
 283                                       phi fn2 fn fi elim dfi crz32 bsum az asum
 284                                       ap akm abw2))
 285         (setf ta (f2cl-lib:d1mach 3))
 286         (setf tol (max ta 1.0e-15))
 287         (setf tb (f2cl-lib:d1mach 5))
 288         (setf ju (f2cl-lib:i1mach 15))
 289         (if (= flgjy 1.0) (go label6))
 290         (setf jr (f2cl-lib:i1mach 14))
 291         (setf elim (* -2.303 tb (f2cl-lib:int-add ju jr)))
 292         (go label7)
 293        label6
 294         (setf elim (* -2.303 (+ (* tb ju) 3.0)))
 295        label7
 296         (setf fn fnu)
 297         (setf iflw 0)
 298         (f2cl-lib:fdo (jn 1 (f2cl-lib:int-add jn 1))
 299                       ((> jn in) nil)
 300           (tagbody
 301             (setf xx (/ x fn))
 302             (setf (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%)
 303                     (- 1.0 (* xx xx)))
 304             (setf abw2 (abs (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%)))
 305             (setf (f2cl-lib:fref wk-%data% (2) ((1 *)) wk-%offset%)
 306                     (f2cl-lib:fsqrt abw2))
 307             (setf (f2cl-lib:fref wk-%data% (7) ((1 *)) wk-%offset%)
 308                     (expt fn con2))
 309             (if (> abw2 0.2775) (go label80))
 310             (setf sa 0.0)
 311             (if (= abw2 0.0) (go label10))
 312             (setf sa (/ tols (f2cl-lib:flog abw2)))
 313            label10
 314             (setf sb sa)
 315             (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
 316                           ((> i 5) nil)
 317               (tagbody
 318                 (setf akm (max sa 2.0))
 319                 (setf (f2cl-lib:fref kmax (i) ((1 5))) (f2cl-lib:int akm))
 320                 (setf sa (+ sa sb))
 321                label20))
 322             (setf kb (f2cl-lib:fref kmax (5) ((1 5))))
 323             (setf klast (f2cl-lib:int-sub kb 1))
 324             (setf sa (f2cl-lib:fref gama (kb) ((1 26))))
 325             (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 326                           ((> k klast) nil)
 327               (tagbody
 328                 (setf kb (f2cl-lib:int-sub kb 1))
 329                 (setf sa
 330                         (+
 331                          (* sa
 332                             (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%))
 333                          (f2cl-lib:fref gama (kb) ((1 26)))))
 334                label30))
 335             (setf z (* (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%) sa))
 336             (setf az (abs z))
 337             (setf rtz (f2cl-lib:fsqrt az))
 338             (setf (f2cl-lib:fref wk-%data% (3) ((1 *)) wk-%offset%)
 339                     (* con1 az rtz))
 340             (setf (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%)
 341                     (* (f2cl-lib:fref wk-%data% (3) ((1 *)) wk-%offset%) fn))
 342             (setf (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)
 343                     (* rtz (f2cl-lib:fref wk-%data% (7) ((1 *)) wk-%offset%)))
 344             (setf (f2cl-lib:fref wk-%data% (6) ((1 *)) wk-%offset%)
 345                     (* (- (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%))
 346                        (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)))
 347             (if (<= z 0.0) (go label35))
 348             (if (> (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%) elim)
 349                 (go label75))
 350             (setf (f2cl-lib:fref wk-%data% (6) ((1 *)) wk-%offset%)
 351                     (- (f2cl-lib:fref wk-%data% (6) ((1 *)) wk-%offset%)))
 352            label35
 353             (setf phi (f2cl-lib:fsqrt (f2cl-lib:fsqrt (+ sa sa sa sa))))
 354             (setf kb (f2cl-lib:fref kmax (5) ((1 5))))
 355             (setf klast (f2cl-lib:int-sub kb 1))
 356             (setf sb (f2cl-lib:fref beta (kb 1) ((1 26) (1 5))))
 357             (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 358                           ((> k klast) nil)
 359               (tagbody
 360                 (setf kb (f2cl-lib:int-sub kb 1))
 361                 (setf sb
 362                         (+
 363                          (* sb
 364                             (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%))
 365                          (f2cl-lib:fref beta (kb 1) ((1 26) (1 5)))))
 366                label40))
 367             (setf ksp1 1)
 368             (setf fn2 (* fn fn))
 369             (setf rfn2 (/ 1.0 fn2))
 370             (setf rden 1.0)
 371             (setf asum 1.0)
 372             (setf relb (* tol (abs sb)))
 373             (setf bsum sb)
 374             (f2cl-lib:fdo (ks 1 (f2cl-lib:int-add ks 1))
 375                           ((> ks 4) nil)
 376               (tagbody
 377                 (setf ksp1 (f2cl-lib:int-add ksp1 1))
 378                 (setf rden (* rden rfn2))
 379                 (setf kstemp (f2cl-lib:int-sub 5 ks))
 380                 (setf kb (f2cl-lib:fref kmax (kstemp) ((1 5))))
 381                 (setf klast (f2cl-lib:int-sub kb 1))
 382                 (setf sa (f2cl-lib:fref alfa (kb ks) ((1 26) (1 4))))
 383                 (setf sb (f2cl-lib:fref beta (kb ksp1) ((1 26) (1 5))))
 384                 (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 385                               ((> k klast) nil)
 386                   (tagbody
 387                     (setf kb (f2cl-lib:int-sub kb 1))
 388                     (setf sa
 389                             (+
 390                              (* sa
 391                                 (f2cl-lib:fref wk-%data%
 392                                                (1)
 393                                                ((1 *))
 394                                                wk-%offset%))
 395                              (f2cl-lib:fref alfa (kb ks) ((1 26) (1 4)))))
 396                     (setf sb
 397                             (+
 398                              (* sb
 399                                 (f2cl-lib:fref wk-%data%
 400                                                (1)
 401                                                ((1 *))
 402                                                wk-%offset%))
 403                              (f2cl-lib:fref beta (kb ksp1) ((1 26) (1 5)))))
 404                    label50))
 405                 (setf ta (* sa rden))
 406                 (setf tb (* sb rden))
 407                 (setf asum (+ asum ta))
 408                 (setf bsum (+ bsum tb))
 409                 (if (and (<= (abs ta) tol) (<= (abs tb) relb)) (go label70))
 410                label60))
 411            label70
 412             (setf bsum
 413                     (/ bsum
 414                        (* fn
 415                           (f2cl-lib:fref wk-%data% (7) ((1 *)) wk-%offset%))))
 416             (go label160)
 417            label75
 418             (setf iflw 1)
 419             (go end_label)
 420            label80
 421             (setf (f2cl-lib:fref upol (1) ((1 10))) 1.0)
 422             (setf tau
 423                     (/ 1.0 (f2cl-lib:fref wk-%data% (2) ((1 *)) wk-%offset%)))
 424             (setf t2 (/ 1.0 (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%)))
 425             (if (>= (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%) 0.0)
 426                 (go label90))
 427             (setf (f2cl-lib:fref wk-%data% (3) ((1 *)) wk-%offset%)
 428                     (abs
 429                      (- (f2cl-lib:fref wk-%data% (2) ((1 *)) wk-%offset%)
 430                         (atan
 431                          (f2cl-lib:fref wk-%data% (2) ((1 *)) wk-%offset%)))))
 432             (setf (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%)
 433                     (* (f2cl-lib:fref wk-%data% (3) ((1 *)) wk-%offset%) fn))
 434             (setf rcz
 435                     (/ (- con1)
 436                        (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%)))
 437             (setf z32
 438                     (* 1.5 (f2cl-lib:fref wk-%data% (3) ((1 *)) wk-%offset%)))
 439             (setf rtz (expt z32 con2))
 440             (setf (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)
 441                     (* rtz (f2cl-lib:fref wk-%data% (7) ((1 *)) wk-%offset%)))
 442             (setf (f2cl-lib:fref wk-%data% (6) ((1 *)) wk-%offset%)
 443                     (* (- (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%))
 444                        (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)))
 445             (go label100)
 446            label90
 447             (setf (f2cl-lib:fref wk-%data% (3) ((1 *)) wk-%offset%)
 448                     (abs
 449                      (-
 450                       (f2cl-lib:flog
 451                        (/
 452                         (+ 1.0
 453                            (f2cl-lib:fref wk-%data% (2) ((1 *)) wk-%offset%))
 454                         xx))
 455                       (f2cl-lib:fref wk-%data% (2) ((1 *)) wk-%offset%))))
 456             (setf (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%)
 457                     (* (f2cl-lib:fref wk-%data% (3) ((1 *)) wk-%offset%) fn))
 458             (setf rcz
 459                     (/ con1 (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%)))
 460             (if (> (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%) elim)
 461                 (go label75))
 462             (setf z32
 463                     (* 1.5 (f2cl-lib:fref wk-%data% (3) ((1 *)) wk-%offset%)))
 464             (setf rtz (expt z32 con2))
 465             (setf (f2cl-lib:fref wk-%data% (7) ((1 *)) wk-%offset%)
 466                     (expt fn con2))
 467             (setf (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)
 468                     (* rtz (f2cl-lib:fref wk-%data% (7) ((1 *)) wk-%offset%)))
 469             (setf (f2cl-lib:fref wk-%data% (6) ((1 *)) wk-%offset%)
 470                     (* (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)
 471                        (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)))
 472            label100
 473             (setf phi (f2cl-lib:fsqrt (* (+ rtz rtz) tau)))
 474             (setf tb 1.0)
 475             (setf asum 1.0)
 476             (setf tfn (/ tau fn))
 477             (setf rden (/ 1.0 fn))
 478             (setf rfn2 (* rden rden))
 479             (setf rden 1.0)
 480             (setf (f2cl-lib:fref upol (2) ((1 10)))
 481                     (*
 482                      (+ (* (f2cl-lib:fref c (1) ((1 65))) t2)
 483                         (f2cl-lib:fref c (2) ((1 65))))
 484                      tfn))
 485             (setf crz32 (* con548 rcz))
 486             (setf bsum (+ (f2cl-lib:fref upol (2) ((1 10))) crz32))
 487             (setf relb (* tol (abs bsum)))
 488             (setf ap tfn)
 489             (setf ks 0)
 490             (setf kp1 2)
 491             (setf rzden rcz)
 492             (setf l 2)
 493             (setf iseta 0)
 494             (setf isetb 0)
 495             (f2cl-lib:fdo (lr 2 (f2cl-lib:int-add lr 2))
 496                           ((> lr 8) nil)
 497               (tagbody
 498                 (setf lrp1 (f2cl-lib:int-add lr 1))
 499                 (f2cl-lib:fdo (k lr (f2cl-lib:int-add k 1))
 500                               ((> k lrp1) nil)
 501                   (tagbody
 502                     (setf ks (f2cl-lib:int-add ks 1))
 503                     (setf kp1 (f2cl-lib:int-add kp1 1))
 504                     (setf l (f2cl-lib:int-add l 1))
 505                     (setf s1 (f2cl-lib:fref c (l) ((1 65))))
 506                     (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1))
 507                                   ((> j kp1) nil)
 508                       (tagbody
 509                         (setf l (f2cl-lib:int-add l 1))
 510                         (setf s1 (+ (* s1 t2) (f2cl-lib:fref c (l) ((1 65)))))
 511                        label110))
 512                     (setf ap (* ap tfn))
 513                     (setf (f2cl-lib:fref upol (kp1) ((1 10))) (* ap s1))
 514                     (setf (f2cl-lib:fref cr (ks) ((1 10)))
 515                             (* (f2cl-lib:fref br (ks) ((1 10))) rzden))
 516                     (setf rzden (* rzden rcz))
 517                     (setf (f2cl-lib:fref dr (ks) ((1 10)))
 518                             (* (f2cl-lib:fref ar (ks) ((1 8))) rzden))
 519                    label120))
 520                 (setf suma (f2cl-lib:fref upol (lrp1) ((1 10))))
 521                 (setf sumb
 522                         (+
 523                          (f2cl-lib:fref upol
 524                                         ((f2cl-lib:int-add lr 2))
 525                                         ((1 10)))
 526                          (* (f2cl-lib:fref upol (lrp1) ((1 10))) crz32)))
 527                 (setf ju lrp1)
 528                 (f2cl-lib:fdo (jr 1 (f2cl-lib:int-add jr 1))
 529                               ((> jr lr) nil)
 530                   (tagbody
 531                     (setf ju (f2cl-lib:int-sub ju 1))
 532                     (setf suma
 533                             (+ suma
 534                                (* (f2cl-lib:fref cr (jr) ((1 10)))
 535                                   (f2cl-lib:fref upol (ju) ((1 10))))))
 536                     (setf sumb
 537                             (+ sumb
 538                                (* (f2cl-lib:fref dr (jr) ((1 10)))
 539                                   (f2cl-lib:fref upol (ju) ((1 10))))))
 540                    label130))
 541                 (setf rden (* rden rfn2))
 542                 (setf tb (- tb))
 543                 (if (> (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%) 0.0)
 544                     (setf tb (abs tb)))
 545                 (if (< rden tol) (go label131))
 546                 (setf asum (+ asum (* suma tb)))
 547                 (setf bsum (+ bsum (* sumb tb)))
 548                 (go label140)
 549                label131
 550                 (if (= iseta 1) (go label132))
 551                 (if (< (abs suma) tol) (setf iseta 1))
 552                 (setf asum (+ asum (* suma tb)))
 553                label132
 554                 (if (= isetb 1) (go label133))
 555                 (if (< (abs sumb) relb) (setf isetb 1))
 556                 (setf bsum (+ bsum (* sumb tb)))
 557                label133
 558                 (if (and (= iseta 1) (= isetb 1)) (go label150))
 559                label140))
 560            label150
 561             (setf tb (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%))
 562             (if (> (f2cl-lib:fref wk-%data% (1) ((1 *)) wk-%offset%) 0.0)
 563                 (setf tb (- tb)))
 564             (setf bsum (/ bsum tb))
 565            label160
 566             (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 567                 (funcall funjy
 568                          (f2cl-lib:fref wk-%data% (6) ((1 *)) wk-%offset%)
 569                          (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)
 570                          (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%)
 571                          fi
 572                          dfi)
 573               (declare (ignore))
 574               (when var-0
 575                 (f2cl-lib:fset
 576                  (f2cl-lib:fref wk-%data% (6) ((1 *)) wk-%offset%)
 577                  var-0))
 578               (when var-1
 579                 (f2cl-lib:fset
 580                  (f2cl-lib:fref wk-%data% (5) ((1 *)) wk-%offset%)
 581                  var-1))
 582               (when var-2
 583                 (f2cl-lib:fset
 584                  (f2cl-lib:fref wk-%data% (4) ((1 *)) wk-%offset%)
 585                  var-2))
 586               (when var-3
 587                 (setf fi var-3))
 588               (when var-4
 589                 (setf dfi var-4)))
 590             (setf ta (/ 1.0 tol))
 591             (setf tb (* (f2cl-lib:d1mach 1) ta 1000.0))
 592             (if (> (abs fi) tb) (go label165))
 593             (setf fi (* fi ta))
 594             (setf dfi (* dfi ta))
 595             (setf phi (* phi tol))
 596            label165
 597             (setf (f2cl-lib:fref y-%data% (jn) ((1 *)) y-%offset%)
 598                     (/ (* flgjy phi (+ (* fi asum) (* dfi bsum)))
 599                        (f2cl-lib:fref wk-%data% (7) ((1 *)) wk-%offset%)))
 600             (setf fn (- fn flgjy))
 601            label170))
 602         (go end_label)
 603        end_label
 604         (return (values nil nil nil nil nil nil nil iflw))))))
 605
 606 (in-package #:cl-user)
 607 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 608 (eval-when (:load-toplevel :compile-toplevel :execute)
 609   (setf (gethash 'fortran-to-lisp::dasyjy
 610                  fortran-to-lisp::*f2cl-function-info*)
 611           (fortran-to-lisp::make-f2cl-finfo
 612            :arg-types '(t (double-float) (double-float) (double-float)
 613                         (fortran-to-lisp::integer4) (array double-float (*))
 614                         (array double-float (*)) (fortran-to-lisp::integer4))
 615            :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::iflw)
 616            :calls '(fortran-to-lisp::i1mach fortran-to-lisp::d1mach))))
 617