relibc_openlibm/slatec/besk1.f

*DECK BESK1
      FUNCTION BESK1 (X)
C***BEGIN PROLOGUE  BESK1
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            third kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK1-S, DBESK1-D)
C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK1(X) computes the modified (hyperbolic) Bessel function of third
C kind of order one for real argument X, where X .GT. 0.
C
C Series for BK1        on the interval  0.          to  4.00000D+00
C                                        with weighted error   7.02E-18
C                                         log weighted error  17.15
C                               significant figures required  16.73
C                                    decimal places required  17.67
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1, BESK1E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESK1
      DIMENSION BK1CS(11)
      LOGICAL FIRST
      SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST
      DATA BK1CS( 1) /    .0253002273 389477705E0 /
      DATA BK1CS( 2) /   -.3531559607 76544876E0 /
      DATA BK1CS( 3) /   -.1226111808 22657148E0 /
      DATA BK1CS( 4) /   -.0069757238 596398643E0 /
      DATA BK1CS( 5) /   -.0001730288 957513052E0 /
      DATA BK1CS( 6) /   -.0000024334 061415659E0 /
      DATA BK1CS( 7) /   -.0000000221 338763073E0 /
      DATA BK1CS( 8) /   -.0000000001 411488392E0 /
      DATA BK1CS( 9) /   -.0000000000 006666901E0 /
      DATA BK1CS(10) /   -.0000000000 000024274E0 /
      DATA BK1CS(11) /   -.0000000000 000000070E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK1
      IF (FIRST) THEN
         NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3))
         XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01)
         XSML = SQRT (4.0*R1MACH(3))
         XMAXT = -LOG(R1MACH(1))
         XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.0) GO TO 20
C
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X SO SMALL K1 OVERFLOWS', 3, 2)
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK1 = LOG(0.5*X)*BESI1(X) +
     1  (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X
      RETURN
C
 20   BESK1 = 0.
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X SO BIG K1 UNDERFLOWS', 1, 1)
      IF (X.GT.XMAX) RETURN
C
      BESK1 = EXP(-X) * BESK1E(X)
C
      RETURN
      END