#include "fpreproc/library_names.h"
#include "fpreproc/f77_dcomplx.h"
#include "fpreproc/fp_const.h"
*DECK DBESJ1
      REAL*8 FUNCTION DBESJ1 (X)
C***BEGIN PROLOGUE  DBESJ1
C***PURPOSE  Compute the Bessel function of the first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      REAL*8 (BESJ1-S, DBESJ1-D)
C***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBESJ1(X) calculates the double precision Bessel function of the
C first kind of order one for double precision argument X.
C
C Series for BJ1        on the interval  0.          to  1.60000E+01
C                                        with weighted error   1.16E-33
C                                         log weighted error  32.93
C                               significant figures required  32.36
C                                    decimal places required  33.57
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9B1MP, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780601  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   910401  Corrected error in code which caused values to have the
C           wrong sign for arguments less than 4.0.  (WRB)
C***END PROLOGUE  DBESJ1
C============
C idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER ntj1,initds
C============
      REAL*8 X, BJ1CS(19), AMPL, THETA, XSML, XMIN, Y,
     1  D1MACH, DCSEVL
      LOGICAL FIRST
      SAVE BJ1CS, NTJ1, XSML, XMIN, FIRST
      DATA BJ1CS(  1) / -CONST(.117261415133327865606240574524003,+0)/
      DATA BJ1CS(  2) / -CONST(.253615218307906395623030884554698,+0)/
      DATA BJ1CS(  3) / +CONST(.501270809844695685053656363203743,-1)/
      DATA BJ1CS(  4) / -CONST(.463151480962508191842619728789772,-2)/
      DATA BJ1CS(  5) / +CONST(.247996229415914024539124064592364,-3)/
      DATA BJ1CS(  6) / -CONST(.867894868627882584521246435176416,-5)/
      DATA BJ1CS(  7) / +CONST(.214293917143793691502766250991292,-6)/
      DATA BJ1CS(  8) / -CONST(.393609307918317979229322764073061,-8)/
      DATA BJ1CS(  9) / +CONST(.559118231794688004018248059864032,-10)/
      DATA BJ1CS( 10) / -CONST(.632761640466139302477695274014880,-12)/
      DATA BJ1CS( 11) / +CONST(.584099161085724700326945563268266,-14)/
      DATA BJ1CS( 12) / -CONST(.448253381870125819039135059199999,-16)/
      DATA BJ1CS( 13) / +CONST(.290538449262502466306018688000000,-18)/
      DATA BJ1CS( 14) / -CONST(.161173219784144165412118186666666,-20)/
      DATA BJ1CS( 15) / +CONST(.773947881939274637298346666666666,-23)/
      DATA BJ1CS( 16) / -CONST(.324869378211199841143466666666666,-25)/
      DATA BJ1CS( 17) / +CONST(.120223767722741022720000000000000,-27)/
      DATA BJ1CS( 18) / -CONST(.395201221265134933333333333333333,-30)/
      DATA BJ1CS( 19) / +CONST(.116167808226645333333333333333333,-32)/
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBESJ1
      IF (FIRST) THEN
         NTJ1 = INITDS (BJ1CS, 19, CONST(0.1,0)*AREAL(D1MACH(3)))
C
         XSML = SQRT(CONST(8.0,0)*D1MACH(3))
         XMIN = CONST(2.0,0)*D1MACH(1)
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.CONST(4.0,0)) GO TO 20
C
      DBESJ1 = CONST(0.0,0)
      IF (Y.EQ.CONST(0.0,0)) RETURN
      IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'DBESJ1',
     +   'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1)
      IF (Y.GT.XMIN) DBESJ1 = CONST(0.5,0)*X
      IF (Y.GT.XSML) DBESJ1 =
     1   X*(CONST(.25,0)+ DCSEVL (CONST(.125,0)*Y*Y-CONST(1.,0),
     1   BJ1CS, NTJ1) )
      RETURN
C
 20   CALL D9B1MP (Y, AMPL, THETA)
      DBESJ1 = SIGN (AMPL, X) * COS(THETA)
C
      RETURN
      END
! 22Jun2000 fgtok -s r8_precision.sub "r8con.csh conversion"
! 22Jun2000 fgtok
! 22Jun2000 fgtok
! 22Jun2000 fgtok
