src/numerical/slatec/fortran/dbesi1.f

   1 *DECK DBESI1
   2       DOUBLE PRECISION FUNCTION DBESI1 (X)
   3 C***BEGIN PROLOGUE  DBESI1
   4 C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
   5 C            first kind of order one.
   6 C***LIBRARY   SLATEC (FNLIB)
   7 C***CATEGORY  C10B1
   8 C***TYPE      DOUBLE PRECISION (BESI1-S, DBESI1-D)
   9 C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
  10 C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS
  11 C***AUTHOR  Fullerton, W., (LANL)
  12 C***DESCRIPTION
  13 C
  14 C DBESI1(X) calculates the double precision modified (hyperbolic)
  15 C Bessel function of the first kind of order one and double precision
  16 C argument X.
  17 C
  18 C Series for BI1        on the interval  0.          to  9.00000E+00
  19 C                                        with weighted error   1.44E-32
  20 C                                         log weighted error  31.84
  21 C                               significant figures required  31.45
  22 C                                    decimal places required  32.46
  23 C
  24 C***REFERENCES  (NONE)
  25 C***ROUTINES CALLED  D1MACH, DBSI1E, DCSEVL, INITDS, XERMSG
  26 C***REVISION HISTORY  (YYMMDD)
  27 C   770701  DATE WRITTEN
  28 C   890531  Changed all specific intrinsics to generic.  (WRB)
  29 C   890531  REVISION DATE from Version 3.2
  30 C   891214  Prologue converted to Version 4.0 format.  (BAB)
  31 C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
  32 C***END PROLOGUE  DBESI1
  33       DOUBLE PRECISION X, BI1CS(17), XMAX, XMIN, XSML, Y, D1MACH,
  34      1  DCSEVL, DBSI1E
  35       LOGICAL FIRST
  36       SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST
  37       DATA BI1CS(  1) / -.1971713261 0998597316 1385032181 49 D-2     /
  38       DATA BI1CS(  2) / +.4073488766 7546480608 1553936520 14 D+0     /
  39       DATA BI1CS(  3) / +.3483899429 9959455866 2450377837 87 D-1     /
  40       DATA BI1CS(  4) / +.1545394556 3001236038 5984010584 89 D-2     /
  41       DATA BI1CS(  5) / +.4188852109 8377784129 4588320041 20 D-4     /
  42       DATA BI1CS(  6) / +.7649026764 8362114741 9597039660 69 D-6     /
  43       DATA BI1CS(  7) / +.1004249392 4741178689 1798080372 38 D-7     /
  44       DATA BI1CS(  8) / +.9932207791 9238106481 3712980548 63 D-10    /
  45       DATA BI1CS(  9) / +.7663801791 8447637275 2001716813 49 D-12    /
  46       DATA BI1CS( 10) / +.4741418923 8167394980 3880919481 60 D-14    /
  47       DATA BI1CS( 11) / +.2404114404 0745181799 8631720320 00 D-16    /
  48       DATA BI1CS( 12) / +.1017150500 7093713649 1211007999 99 D-18    /
  49       DATA BI1CS( 13) / +.3645093565 7866949458 4917333333 33 D-21    /
  50       DATA BI1CS( 14) / +.1120574950 2562039344 8106666666 66 D-23    /
  51       DATA BI1CS( 15) / +.2987544193 4468088832 0000000000 00 D-26    /
  52       DATA BI1CS( 16) / +.6973231093 9194709333 3333333333 33 D-29    /
  53       DATA BI1CS( 17) / +.1436794822 0620800000 0000000000 00 D-31    /
  54       DATA FIRST /.TRUE./
  55 C***FIRST EXECUTABLE STATEMENT  DBESI1
  56       IF (FIRST) THEN
  57          NTI1 = INITDS (BI1CS, 17, 0.1*REAL(D1MACH(3)))
  58          XMIN = 2.0D0*D1MACH(1)
  59          XSML = SQRT(4.5D0*D1MACH(3))
  60          XMAX = LOG (D1MACH(2))
  61       ENDIF
  62       FIRST = .FALSE.
  63 C
  64       Y = ABS(X)
  65       IF (Y.GT.3.0D0) GO TO 20
  66 C
  67       DBESI1 = 0.D0
  68       IF (Y.EQ.0.D0)  RETURN
  69 C
  70       IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBESI1',
  71      +   'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1)
  72       IF (Y.GT.XMIN) DBESI1 = 0.5D0*X
  73       IF (Y.GT.XSML) DBESI1 = X*(0.875D0 + DCSEVL (Y*Y/4.5D0-1.D0,
  74      1  BI1CS, NTI1))
  75       RETURN
  76 C
  77  20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESI1',
  78      +   'ABS(X) SO BIG I1 OVERFLOWS', 2, 2)
  79 C
  80       DBESI1 = EXP(Y) * DBSI1E(X)
  81 C
  82       RETURN
  83       END