src/numerical/slatec/fortran/dbsk1e.f

   1 *DECK DBSK1E
   2       DOUBLE PRECISION FUNCTION DBSK1E (X)
   3 C***BEGIN PROLOGUE  DBSK1E
   4 C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
   5 C            Bessel function of the third kind of order one.
   6 C***LIBRARY   SLATEC (FNLIB)
   7 C***CATEGORY  C10B1
   8 C***TYPE      DOUBLE PRECISION (BESK1E-S, DBSK1E-D)
   9 C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION,
  10 C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
  11 C             THIRD KIND
  12 C***AUTHOR  Fullerton, W., (LANL)
  13 C***DESCRIPTION
  14 C
  15 C DBSK1E(S) computes the double precision exponentially scaled
  16 C modified (hyperbolic) Bessel function of the third kind of order
  17 C one for positive double precision argument X.
  18 C
  19 C Series for BK1        on the interval  0.          to  4.00000E+00
  20 C                                        with weighted error   9.16E-32
  21 C                                         log weighted error  31.04
  22 C                               significant figures required  30.61
  23 C                                    decimal places required  31.64
  24 C
  25 C Series for AK1        on the interval  1.25000E-01 to  5.00000E-01
  26 C                                        with weighted error   3.07E-32
  27 C                                         log weighted error  31.51
  28 C                               significant figures required  30.71
  29 C                                    decimal places required  32.30
  30 C
  31 C Series for AK12       on the interval  0.          to  1.25000E-01
  32 C                                        with weighted error   2.41E-32
  33 C                                         log weighted error  31.62
  34 C                               significant figures required  30.25
  35 C                                    decimal places required  32.38
  36 C
  37 C***REFERENCES  (NONE)
  38 C***ROUTINES CALLED  D1MACH, DBESI1, DCSEVL, INITDS, XERMSG
  39 C***REVISION HISTORY  (YYMMDD)
  40 C   770701  DATE WRITTEN
  41 C   890531  Changed all specific intrinsics to generic.  (WRB)
  42 C   890531  REVISION DATE from Version 3.2
  43 C   891214  Prologue converted to Version 4.0 format.  (BAB)
  44 C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  45 C***END PROLOGUE  DBSK1E
  46       DOUBLE PRECISION X, BK1CS(16), AK1CS(38), AK12CS(33), XMIN,
  47      1  XSML, Y, D1MACH, DCSEVL, DBESI1
  48       LOGICAL FIRST
  49       SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML,
  50      1  FIRST
  51       DATA BK1CS(  1) / +.2530022733 8947770532 5311208685 33 D-1     /
  52       DATA BK1CS(  2) / -.3531559607 7654487566 7238316918 01 D+0     /
  53       DATA BK1CS(  3) / -.1226111808 2265714823 4790679300 42 D+0     /
  54       DATA BK1CS(  4) / -.6975723859 6398643501 8129202960 83 D-2     /
  55       DATA BK1CS(  5) / -.1730288957 5130520630 1765073689 79 D-3     /
  56       DATA BK1CS(  6) / -.2433406141 5659682349 6007350301 64 D-5     /
  57       DATA BK1CS(  7) / -.2213387630 7347258558 3152525451 26 D-7     /
  58       DATA BK1CS(  8) / -.1411488392 6335277610 9583302126 08 D-9     /
  59       DATA BK1CS(  9) / -.6666901694 1993290060 8537512643 73 D-12    /
  60       DATA BK1CS( 10) / -.2427449850 5193659339 2631968648 53 D-14    /
  61       DATA BK1CS( 11) / -.7023863479 3862875971 7837971200 00 D-17    /
  62       DATA BK1CS( 12) / -.1654327515 5100994675 4910293333 33 D-19    /
  63       DATA BK1CS( 13) / -.3233834745 9944491991 8933333333 33 D-22    /
  64       DATA BK1CS( 14) / -.5331275052 9265274999 4666666666 66 D-25    /
  65       DATA BK1CS( 15) / -.7513040716 2157226666 6666666666 66 D-28    /
  66       DATA BK1CS( 16) / -.9155085717 6541866666 6666666666 66 D-31    /
  67       DATA AK1CS(  1) / +.2744313406 9738829695 2576662272 66 D+0     /
  68       DATA AK1CS(  2) / +.7571989953 1993678170 8923781492 90 D-1     /
  69       DATA AK1CS(  3) / -.1441051556 4754061229 8531161756 25 D-2     /
  70       DATA AK1CS(  4) / +.6650116955 1257479394 2513854770 36 D-4     /
  71       DATA AK1CS(  5) / -.4369984709 5201407660 5808450891 67 D-5     /
  72       DATA AK1CS(  6) / +.3540277499 7630526799 4171390085 34 D-6     /
  73       DATA AK1CS(  7) / -.3311163779 2932920208 9826882457 04 D-7     /
  74       DATA AK1CS(  8) / +.3445977581 9010534532 3114997709 92 D-8     /
  75       DATA AK1CS(  9) / -.3898932347 4754271048 9819374927 58 D-9     /
  76       DATA AK1CS( 10) / +.4720819750 4658356400 9474493390 05 D-10    /
  77       DATA AK1CS( 11) / -.6047835662 8753562345 3735915628 90 D-11    /
  78       DATA AK1CS( 12) / +.8128494874 8658747888 1938379856 63 D-12    /
  79       DATA AK1CS( 13) / -.1138694574 7147891428 9239159510 42 D-12    /
  80       DATA AK1CS( 14) / +.1654035840 8462282325 9729482050 90 D-13    /
  81       DATA AK1CS( 15) / -.2480902567 7068848221 5160104405 33 D-14    /
  82       DATA AK1CS( 16) / +.3829237890 7024096948 4292272991 57 D-15    /
  83       DATA AK1CS( 17) / -.6064734104 0012418187 7682103773 86 D-16    /
  84       DATA AK1CS( 18) / +.9832425623 2648616038 1940046506 66 D-17    /
  85       DATA AK1CS( 19) / -.1628416873 8284380035 6666201156 26 D-17    /
  86       DATA AK1CS( 20) / +.2750153649 6752623718 2841203370 66 D-18    /
  87       DATA AK1CS( 21) / -.4728966646 3953250924 2810695680 00 D-19    /
  88       DATA AK1CS( 22) / +.8268150002 8109932722 3920503466 66 D-20    /
  89       DATA AK1CS( 23) / -.1468140513 6624956337 1939648853 33 D-20    /
  90       DATA AK1CS( 24) / +.2644763926 9208245978 0858948266 66 D-21    /
  91       DATA AK1CS( 25) / -.4829015756 4856387897 9698688000 00 D-22    /
  92       DATA AK1CS( 26) / +.8929302074 3610130180 6563327999 99 D-23    /
  93       DATA AK1CS( 27) / -.1670839716 8972517176 9977514666 66 D-23    /
  94       DATA AK1CS( 28) / +.3161645603 4040694931 3686186666 66 D-24    /
  95       DATA AK1CS( 29) / -.6046205531 2274989106 5064106666 66 D-25    /
  96       DATA AK1CS( 30) / +.1167879894 2042732700 7184213333 33 D-25    /
  97       DATA AK1CS( 31) / -.2277374158 2653996232 8678400000 00 D-26    /
  98       DATA AK1CS( 32) / +.4481109730 0773675795 3058133333 33 D-27    /
  99       DATA AK1CS( 33) / -.8893288476 9020194062 3360000000 00 D-28    /
 100       DATA AK1CS( 34) / +.1779468001 8850275131 3920000000 00 D-28    /
 101       DATA AK1CS( 35) / -.3588455596 7329095821 9946666666 66 D-29    /
 102       DATA AK1CS( 36) / +.7290629049 2694257991 6799999999 99 D-30    /
 103       DATA AK1CS( 37) / -.1491844984 5546227073 0240000000 00 D-30    /
 104       DATA AK1CS( 38) / +.3073657387 2934276300 7999999999 99 D-31    /
 105       DATA AK12CS(  1) / +.6379308343 7390010366 0048853410 2 D-1      /
 106       DATA AK12CS(  2) / +.2832887813 0497209358 3503028470 8 D-1      /
 107       DATA AK12CS(  3) / -.2475370673 9052503454 1454556673 2 D-3      /
 108       DATA AK12CS(  4) / +.5771972451 6072488204 7097662576 3 D-5      /
 109       DATA AK12CS(  5) / -.2068939219 5365483027 4553319655 2 D-6      /
 110       DATA AK12CS(  6) / +.9739983441 3818041803 0921309788 7 D-8      /
 111       DATA AK12CS(  7) / -.5585336140 3806249846 8889551112 9 D-9      /
 112       DATA AK12CS(  8) / +.3732996634 0461852402 2121285473 1 D-10     /
 113       DATA AK12CS(  9) / -.2825051961 0232254451 3506575492 8 D-11     /
 114       DATA AK12CS( 10) / +.2372019002 4841441736 4349695548 6 D-12     /
 115       DATA AK12CS( 11) / -.2176677387 9917539792 6830166793 8 D-13     /
 116       DATA AK12CS( 12) / +.2157914161 6160324539 3956268970 6 D-14     /
 117       DATA AK12CS( 13) / -.2290196930 7182692759 9155133815 4 D-15     /
 118       DATA AK12CS( 14) / +.2582885729 8232749619 1993956522 6 D-16     /
 119       DATA AK12CS( 15) / -.3076752641 2684631876 2109817344 0 D-17     /
 120       DATA AK12CS( 16) / +.3851487721 2804915970 9489684479 9 D-18     /
 121       DATA AK12CS( 17) / -.5044794897 6415289771 1728250880 0 D-19     /
 122       DATA AK12CS( 18) / +.6888673850 4185442370 1829222399 9 D-20     /
 123       DATA AK12CS( 19) / -.9775041541 9501183030 0213248000 0 D-21     /
 124       DATA AK12CS( 20) / +.1437416218 5238364610 0165973333 3 D-21     /
 125       DATA AK12CS( 21) / -.2185059497 3443473734 9973333333 3 D-22     /
 126       DATA AK12CS( 22) / +.3426245621 8092206316 4538880000 0 D-23     /
 127       DATA AK12CS( 23) / -.5531064394 2464082325 0124800000 0 D-24     /
 128       DATA AK12CS( 24) / +.9176601505 6859954037 8282666666 6 D-25     /
 129       DATA AK12CS( 25) / -.1562287203 6180249114 4874666666 6 D-25     /
 130       DATA AK12CS( 26) / +.2725419375 4843331323 4943999999 9 D-26     /
 131       DATA AK12CS( 27) / -.4865674910 0748279923 7802666666 6 D-27     /
 132       DATA AK12CS( 28) / +.8879388552 7235025873 5786666666 6 D-28     /
 133       DATA AK12CS( 29) / -.1654585918 0392575489 3653333333 3 D-28     /
 134       DATA AK12CS( 30) / +.3145111321 3578486743 0399999999 9 D-29     /
 135       DATA AK12CS( 31) / -.6092998312 1931276124 1600000000 0 D-30     /
 136       DATA AK12CS( 32) / +.1202021939 3698158346 2399999999 9 D-30     /
 137       DATA AK12CS( 33) / -.2412930801 4594088413 8666666666 6 D-31     /
 138       DATA FIRST /.TRUE./
 139 C***FIRST EXECUTABLE STATEMENT  DBSK1E
 140       IF (FIRST) THEN
 141          ETA = 0.1*REAL(D1MACH(3))
 142          NTK1 = INITDS (BK1CS, 16, ETA)
 143          NTAK1 = INITDS (AK1CS, 38, ETA)
 144          NTAK12 = INITDS (AK12CS, 33, ETA)
 145 C
 146          XMIN = EXP (MAX(LOG(D1MACH(1)), -LOG(D1MACH(2))) + 0.01D0)
 147          XSML = SQRT(4.0D0*D1MACH(3))
 148       ENDIF
 149       FIRST = .FALSE.
 150 C
 151       IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBSK1E',
 152      +   'X IS ZERO OR NEGATIVE', 2, 2)
 153       IF (X.GT.2.0D0) GO TO 20
 154 C
 155       IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'DBSK1E',
 156      +   'X SO SMALL K1 OVERFLOWS', 3, 2)
 157       Y = 0.D0
 158       IF (X.GT.XSML) Y = X*X
 159       DBSK1E = EXP(X)*(LOG(0.5D0*X)*DBESI1(X) + (0.75D0 +
 160      1  DCSEVL (0.5D0*Y-1.D0, BK1CS, NTK1))/X )
 161       RETURN
 162 C
 163  20   IF (X.LE.8.D0) DBSK1E = (1.25D0 + DCSEVL ((16.D0/X-5.D0)/3.D0,
 164      1  AK1CS, NTAK1))/SQRT(X)
 165       IF (X.GT.8.D0) DBSK1E = (1.25D0 +
 166      1  DCSEVL (16.D0/X-1.D0, AK12CS, NTAK12))/SQRT(X)
 167 C
 168       RETURN
 169       END