c
c  This file contains the bessel function routines needed by
c   curray
c----------------------------------------------------------------
c



       subroutine cbesin
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:13   6/14/01  
C...Switches: -p4 -yb
c--------------------------
c  this tabulates bessel I functions from order zero to nli-1=nli-1
c  in intervals of hin
c--------------------------
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      USE Vcombes
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n, np, iier
      real, dimension(nli) :: work
      real :: hin, x
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
      data hin/0.01/
      bsir(1,:nli-1) = 0.
      bsir(1,0) = 1.
      xin(1) = 0.
      do np = 2, nbitab
         x = (np - 1.)*hin
         xin(np) = x
c         call mmbsir (x, 0., nli, 2, work, iier)
         call dbesi(x, 0., 2, nli, work, iier)
c     call bsies(0.,x,nli,work)
c-----------------------
c  mmbsir:imsl subroutine for Bessel function of first kind
c         of nonnegative integer order for real arguments
c      x=argument of i; nli=number of function values to be computed;
c      work(ni)=array containing bessel-function values from order
c               zero to order nli-1; ier=error indicater.
c           scaling option=2 scaled by exp(-x).
c------------------------
         bsir(np,:nli-1) = work(:nli)
      end do
      return 
      end subroutine cbesin


      subroutine ibesin(n, bsi, x)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:13   6/14/01  
C...Switches: -p4 -yb
c
c   find bessel I's of order 0 to n-1 at x
c   by interpolation or asymptotic formula
c
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
!      use Vparam
      USE Vcombes
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer n
      real x
      real, dimension(n) :: bsi
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: nnx, j, j1
      real, dimension(nli) :: sum, wk1, wk2, wk3
      real :: hin, pi, xn, y1, y
C-----------------------------------------------
c
c  parameters
c  Nspect-->nspectm, Nion-->nions,  Nua-->nuam,  Nta-->ntam, Lrz-->lrza,
c  Nthp11-->nthp11a,  Npnt-->npnta,   Mpnt-->mpnta
c
      data hin/0.01/
      data pi/3.14159265/
      xn = x/hin
      nnx = xn - 1
      if (nnx <= nbitab - 2) then
         if (nnx <= 100) go to 200
         wk1(:n) = bsir(nnx,:n-1)
         wk2(:n) = bsir(nnx+1,:n-1)
         wk3(:n) = bsir(nnx+2,:n-1)
         call intern (bsi, x, wk1, wk2, wk3, xin(nnx), xin(nnx+1), xin(
     1      nnx+2), n)
         return 
      endif
      y1 = sqrt(0.5/x/pi)
      bsi(:n) = y1
      return 
  200 continue
      sum(:n) = 1.
      do j = 2, n
         j1 = j - 1
         sum(j) = sum(j1)*0.5*x/j1
      end do
      y = 0.25*x**2
      do j = 1, n
         bsi(j) = sum(j)*(1. + y/j*(1. + y/2./(j + 2.)*(1. + y/3./(j + 
     1      3.)*(1. + y/4./(j + 4.)))))
      end do
      return 
      end subroutine ibesin

 
      subroutine besfun(l1, nx, nx1, x, bes, h, mx, wk)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:13   6/14/01  
C...Switches: -p4 -yb
C-----------------------------------------------
C   M o d u l e s 
C-----------------------------------------------
      USE Vbesblk
      implicit none
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer l1, nx, nx1
      real h
      integer, dimension(nx1) :: mx
      real, dimension(nx1) :: x, bes
      real, dimension(nx1,2) :: wk
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: l2, i
      real :: one, two, zero
C-----------------------------------------------
c--------------------------------
c  Input:
c  bessel function subroutine
c  l1=order of bessel function
c  nx is number of points evaluated (.le.nx1)
c  nx1 is exact dimension of bes,mx.
c  x(nx) are argument values
c  Output:
c  bes(nx) are values of bessel functions at x(nx)
c
c
c  it is assumed that the bessel function table bestb(nbsx,lbes)
c  already exists from order lmn to lmx in the array bestb(nbsx,1:lmx-lmn+1)
c   h=grid size of table
c      usually 0.005
c-------------------------------
      data one/1.E0/
      data two/2.E0/
      data zero/0./
 
      l2 = l1 - lmn + 1
      mx(:nx) = (x(:nx)/h) + 1
      wk(:nx,1) = bestb(mx(:nx),l2)
      wk(:nx,2) = bestb(mx(:nx)+1,l2)
      bes(:nx)=wk(:nx,1)+((x(:nx)/h)-mx(:nx)+one)*(wk(:nx,2)-wk(:nx,1))
      return 
      end subroutine besfun
 
 
      subroutine besj(x, n, bj, d, ier)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:13   6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer n, ier
      real x, bj, d
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: ntest, n1, ma, mb, mzero, mmax, m, jt, m2, k, mk
      real :: bprev, fm1, fm, alpha, bmk, s
C-----------------------------------------------
c-----------------------------------------------------------------------
c     i.b.m. bessel function j
c     x  - argument
c     n  - order (integer .ge. 0)
c     bj - j(x)
c     d  - relative allowable error (input)
c     ier- error switch, if ier=0 all is ok
c-----------------------------------------------------------------------
      bj = 0.
      if (n < 0) then
         ier = 1
         return 
      endif
      if (x <= 0.) then
         ier = 2
         bj = 0.
         if (n == 0) bj = 1.
         return 
      endif
      if (x - 15. <= 0.) then
         ntest = 20. + 10.*x - x*x/3
      else
         ntest = 90. + x/2.
      endif
      if (n - ntest >= 0) then
         ier = 4
         return 
      endif
      ier = 0
      n1 = n + 1
      bprev = 0.
      if (x - 5. < 0.) then
         ma = x + 6.
      else
         ma = 1.4*x + 60./x
      endif
      mb = n + ifix(x)/4 + 2
      mzero = max0(ma,mb)
      mmax = ntest
      do m = mzero, mmax, 3
         fm1 = 1.E-28
         fm = 0.
         alpha = 0.
         if (m - (m/2)*2 == 0) then
            jt = -1
         else
            jt = 1
         endif
         m2 = m - 2
         do k = 1, m2
            mk = m - k
            bmk = 2.*float(mk)*fm1/x - fm
            fm = fm1
            fm1 = bmk
            if (mk - n - 1 == 0) then
               bj = bmk
            endif
            jt = -jt
            s = 1 + jt
            alpha = alpha + bmk*s
         end do
         bmk = 2.*fm1/x - fm
         if (n == 0) then
            bj = bmk
         endif
         alpha = alpha + bmk
         bj = bj/alpha
         if (abs(bj - bprev) - abs(d*bj) <= 0.) go to 200
         bprev = bj
      end do
      ier = 3
  200 continue
      return 
      end subroutine besj
c
ctk--calculation of Bessel function with a complex argument (x,y)
      subroutine beslci(x, y, nb, ize, br, bi, ncalc)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:13   6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer nb, ize, ncalc
      real x, y
      real, dimension(*) :: br, bi
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: nsig, nten, largez, magz, nbmz, n, m, nstart, nend, 
     1   ipos, mrecur, k, l, mlast, imrecr, imag
      real :: exparg, tempar, sign1, zinvr, zinvi, plastr, plasti, pr, 
     1   pi, test, tover, poldr, poldi, tempbi, tempbr, psaver, psavei, 
     2   tempcr, tempci, tempai, sumr, sumi
C-----------------------------------------------
c
c*****     *****     *****     *****     *****     *****     *****
c
c     journal of research  national bureau of standards
c     b-mathematical sciences   vol.77-b  nos.3-4  july-dec. 1973  p118
c     routine to calculate bessel functions j and i
c     of complex argument and integer order
c                  input variables
c     x real part of complex argument
c     y imaginary part of complex argument
c     nb a positive integer designating highest order to be calculated
c     ize     zero for j*s    one for i*s
c     br  for normal exit,br contains real part of solution vector
c     bi  for normal exit,bi contains imaginary part of solution vector
c     normal exit if  ncalc=nb
c     br-bi-ncalc need not be initialized
c                  machine dependent constants
c     nsig  decimal significance desired. set to ifix(alog10(2)*nbit+1)
c     nbit  number of bits in the mantissa
c     the relative truncation error is limited to t=.5*10**-nsig for
c     order greater than abs(z).
c     for order less than abs(z) (general test),the relative error is
c     limited to t for function values of magnitude at least 1.
c     the absolute error is limited to t for smaller values.
c     nten  largest integer k such that 10**k is machine representable.
c     largez  upper limit on the magnitude of z. if abs(z)=n, at least
c     n iterations of the backward recursion will be executed.
c     exparg  largest argument that the library exp routine can handle.
c                  error returns
c     let g denote either i or j.
c     in case of an error, ncalc.ne.nb and not all g*s are calculated
c     to the desired accuracy.
c     if ncalc.lt.0, an argument is out of range. nb.le.0 or ize is
c     neither 0 nor 1 or ize=0 and abs(y).gt.exparg, or ize=1 and
c     abs(x).gt.exparg. in this case,the vectors br and bi are not
c     calculated, and ncalc is set to min0(nb,0)-1 so ncalc.ne.nb.
c     nb.gt.ncalc.gt.0 will occur if nb.gt.magz and abs(g-sub-nb-of-z/g
c     -sub-magx-of-z).lt.10.**(nten/2), i.e. nb is much greater than
c     magz. in this case, br(n) and bi(n) are calculated to the desired
c     accuracy for n.le.ncalc, but for ncalc.lt.n.le.nb, precision  is
c     lost. if n.gt.ncalc and abs(g(ncalc-1)/g(n-1)).eq.10**-k, then
c     the last k significant figures of g(n-1) (=br(n)+i*bi(n)) are
c     erroneous. if the user wishes to calculate g(n-1) to higher
c     accuracy, he should use an asymptotic formula for large order.
c
c*****     *****     *****     *****     *****     *****     *****
c
      data nsig, nten, largez, exparg/15, 307, 10000, 700./
      tempar = sqrt(x*x + y*y)
      magz = ifix(tempar)
      if (.not.(nb>0 .and. magz<=largez .and. (ize==0 .and. abs(y)<=
     1   exparg .or. ize==1 .and. abs(x)<=exparg))) then
c     error return    z,nb,or ize is out of range
         ncalc = min0(nb,0) - 1
         return 
      endif
      sign1 = 1 - 2*ize
      ncalc = nb
c     use 2-term ascending series for small z
      if (tempar**4 >= 0.1**nsig) then
c     initialize the calculation of the p*s
         nbmz = nb - magz
         n = magz + 1
         if (abs(x) >= abs(y)) then
            zinvr = 1.0/(x + y*y/x)
            zinvi = -y*zinvr/x
         else
            zinvi = -1.0/(y + x*x/y)
            zinvr = -x*zinvi/y
         endif
         plastr = 1.0
         plasti = 0.0
         pr = sign1*(n + n)*zinvr
         pi = sign1*(n + n)*zinvi
         test = 2.0*10.0**nsig
         m = 0
         if (nbmz >= 3) then
c     calculate p*s until n=nb-1.  check for possible overflow.
            tover = 10.0**(nten - nsig)
            nstart = magz + 2
            nend = nb - 1
            do n = nstart, nend
               poldr = plastr
               poldi = plasti
               plastr = pr
               plasti = pi
               pr=sign1*((n+n)*(plastr*zinvr-plasti*zinvi)-poldr)
               pi=sign1*((n+n)*(plasti*zinvr+plastr*zinvi)-poldi)
               if ((pr/tover)**2 + (pi/tover)**2 - 1.0 > 0.) go to 7
            end do
            n = nend
c     calculate special significance test for nbmz.gt.2.
            tempbi = amax1(abs(pr),abs(pi))
            tempbi = tempbi*sqrt(2.0*10.0**nsig*sqrt(((pr/tempbi)**2 + (
     1         pi/tempbi)**2)*((plastr/tempbi)**2 + (plasti/tempbi)**2))
     2         )
            test = amax1(test,tempbi)
c     calculate p*s until significance test is passed
         endif
    6    continue
         n = n + 1
         poldr = plastr
         poldi = plasti
         plastr = pr
         plasti = pi
         pr = sign1*((n + n)*(plastr*zinvr - plasti*zinvi) - poldr)
         pi = sign1*((n + n)*(plasti*zinvr + plastr*zinvi) - poldi)
         do while((pr/test)**2 + (pi/test)**2 < 1.0)
            n = n + 1
            poldr = plastr
            poldi = plasti
            plastr = pr
            plasti = pi
            pr = sign1*((n + n)*(plastr*zinvr - plasti*zinvi) - poldr)
            pi = sign1*((n + n)*(plasti*zinvr + plastr*zinvi) - poldi)
         end do
         if (m == 1) go to 12
c     calculate strict variant of significance test,and
c     calculate p*s until this test is passed.
         m = 1
         tempbi = amax1(abs(pr),abs(pi))
         tempbr = sqrt(((pr/tempbi)**2 + (pi/tempbi)**2)/((plastr/tempbi
     1      )**2 + (plasti/tempbi)**2))
         tempbi = (n + 1)/tempar
         if (tempbr + 1.0/tempbr > 2.0*tempbi) tempbr = tempbi + sqrt(
     1      tempbi**2 - 1.0)
         test = test/sqrt(tempbr - 1.0/tempbr)
         if ((pr/test)**2 + (pi/test)**2 - 1.0 < 0.) go to 6
         go to 12
    7    continue
         nstart = n + 1
c     to avoid overflow, normalize p*s by dividing by tover.
c     calculate p*s until unnormalized p would overflow.
         pr = pr/tover
         pi = pi/tover
         plastr = plastr/tover
         plasti = plasti/tover
         psaver = pr
         psavei = pi
         tempcr = plastr
         tempci = plasti
         test = 10.0**(2*nsig)
         n = n + 1
         poldr = plastr
         poldi = plasti
         plastr = pr
         plasti = pi
         pr = sign1*((n + n)*(plastr*zinvr - plasti*zinvi) - poldr)
         pi = sign1*((n + n)*(plasti*zinvr + plastr*zinvi) - poldi)
         do while(pr**2 + pi**2 <= test)
            n = n + 1
            poldr = plastr
            poldi = plasti
            plastr = pr
            plasti = pi
            pr = sign1*((n + n)*(plastr*zinvr - plasti*zinvi) - poldr)
            pi = sign1*((n + n)*(plasti*zinvr + plastr*zinvi) - poldi)
         end do
c     calculate backward test,and find ncalc,the highest n
c     such that the test is passed.
         tempbr = sqrt((plastr**2 + plasti**2)/(poldr**2 + poldi**2))
         tempbi = n/tempar
         if (tempbr + 1.0/tempbr > 2.0*tempbi) tempbr = tempbi + sqrt(
     1      tempbi**2 - 1.0)
         test = 0.5*(1.0 - 1.0/tempbr**2)/10.0**nsig
         test=((plastr**2+plasti**2)*test)*((poldr**2+poldi**2)*test)
         pr = plastr*tover
         pi = plasti*tover
         n = n - 1
         nend = min0(nb,n)
         do ncalc = nstart, nend
            poldr = tempcr
            poldi = tempci
            tempcr = psaver
            tempci = psavei
            psaver=sign1*((n+n)*(tempcr*zinvr-tempci*zinvi)-poldr)
            psavei=sign1*((n+n)*(tempci*zinvr+tempcr*zinvi)-poldi)
            if ((psaver**2 + psavei**2)*(tempcr**2 + tempci**2) - test
     1          > 0.) go to 10
         end do
         ncalc = nend + 1
   10    continue
         ncalc = ncalc - 1
c     the coefficient of b(n) in the normalized sum is
c     m*sqrt(-1)**imag,where m=-2,0,or2,and imag is 0 or 1.
c     calculate recursion rules for m and imag,and initialize them.
   12    continue
         n = n + 1
         tempbr = ize*x + (1 - ize)*y
         ipos = 0
         if (tempbr /= 0.) then
            ipos = ifix(1.1*tempbr/abs(tempbr))
         endif
         mrecur = 4*((2 + ize + ipos)/2) - 3 - 2*(ize + ipos)
         k = 2 + ipos + 2*ize*ipos**2 - ize
         l = n - 4*(n/4)
         mlast = 2 + 8*((k*l)/4) - 4*((k*l)/2)
         if (ipos==0 .and. (l==1 .or. l==3)) mlast = 0
         l = l + 3 - 4*((l + 3)/4)
         m = 2 + 8*((k*l)/4) - 4*((k*l)/2)
         if (ipos==0 .and. (l==1 .or. l==3)) m = 0
         imrecr = (1 - ize)*ipos**2
         imag = imrecr*(l - 2*(l/2))
c     initialize the backward recursion and the normalization sum
         tempbr = 0.0
         tempbi = 0.0
         if (abs(pi) <= abs(pr)) then
            tempar = 1.0/(pr + pi*(pi/pr))
            tempai = -(pi*tempar)/pr
         else
            tempai = -1.0/(pi + pr*(pr/pi))
            tempar = -(pr*tempai)/pi
         endif
         if (imag == 0) then
            sumr = m*tempar
            sumi = m*tempai
         else
            sumr = -m*tempai
            sumi = m*tempar
         endif
         nend = n - nb
         if (nend >= 0) then
            if (nend /= 0) then
               do l = 1, nend
                  n = n - 1
                  tempcr = tempbr
                  tempci = tempbi
                  tempbr = tempar
                  tempbi = tempai
                  pr = (n + n)*zinvr
                  pi = (n + n)*zinvi
                  tempar = pr*tempbr - pi*tempbi - sign1*tempcr
                  tempai = pr*tempbi + pi*tempbr - sign1*tempci
                  imag = (1 - imag)*imrecr
                  k = mlast
                  mlast = m
                  m = k*mrecur
                  if (imag == 0) then
                     sumr = sumr + m*tempar
                     sumi = sumi + m*tempai
                  else
                     sumr = sumr - m*tempai
                     sumi = sumi + m*tempar
                  endif
               end do
c     store  br(nb),bi(nb)
            endif
            br(n) = tempar
            bi(n) = tempai
            if (n <= 1) then
c     nb=1.  since 2*tempar and 2*tempai were added to sumr and sumi
c     respectively,we must subaxis(i)ract tempar and tempai
               sumr = sumr - tempar
               sumi = sumi - tempai
               go to 35
c     calculate and store br(nb-1),bi(nb-1)
            endif
            n = n - 1
            pr = (n + n)*zinvr
            pi = (n + n)*zinvi
            br(n) = pr*tempar - pi*tempai - sign1*tempbr
            bi(n) = pr*tempai + pi*tempar - sign1*tempbi
            if (n == 1) go to 34
            imag = (1 - imag)*imrecr
            k = mlast
            mlast = m
            m = k*mrecur
            if (imag == 0) then
               sumr = sumr + m*br(n)
               sumi = sumi + m*bi(n)
               go to 30
            endif
            sumr = sumr - m*bi(n)
            sumi = sumi + m*br(n)
            go to 30
c     n.lt.nb,so store br(n),bi(n) and set higher orders zero
         endif
         br(n) = tempar
         bi(n) = tempai
         nend = -nend
         br(n+1:nend+n) = 0.0
         bi(n+1:nend+n) = 0.0
   30    continue
         nend = n - 2
         if (nend /= 0) then
c     calculate via difference equation and store br(n),bi(n)
c     until n=2
            do l = 1, nend
               n = n - 1
               pr = (n + n)*zinvr
               pi = (n + n)*zinvi
               br(n) = pr*br(n+1) - pi*bi(n+1) - sign1*br(n+2)
               bi(n) = pr*bi(n+1) + pi*br(n+1) - sign1*bi(n+2)
               imag = (1 - imag)*imrecr
               k = mlast
               mlast = m
               m = k*mrecur
               if (imag == 0) then
                  sumr = sumr + m*br(n)
                  sumi = sumi + m*bi(n)
               else
                  sumr = sumr - m*bi(n)
                  sumi = sumi + m*br(n)
               endif
            end do
c     calculate and store br(1),bi(1)
         endif
         br(1) = 2.0*(br(2)*zinvr-bi(2)*zinvi) - sign1*br(3)
         bi(1) = 2.0*(br(2)*zinvi+bi(2)*zinvr) - sign1*bi(3)
   34    continue
         sumr = sumr + br(1)
         sumi = sumi + bi(1)
c     calculate normalization factor. tempar+i*tempai
   35    continue
         if (ize /= 1) then
            tempcr = ipos*y
            tempci = -ipos*x
         else
            tempcr = ipos*x
            tempci = ipos*y
         endif
         tempcr = exp(tempcr)
         tempbr = cos(tempci)
         tempbi = sin(tempci)
         if (abs(sumr) >= abs(sumi)) then
            tempci = sumi/sumr
            tempcr = (tempcr/sumr)/(1.0 + tempci*tempci)
            tempar = tempcr*(tempbr + tempbi*tempci)
            tempai = tempcr*(tempbi - tempbr*tempci)
         else
            tempci = sumr/sumi
            tempcr = (tempcr/sumi)/(1.0 + tempci*tempci)
            tempar = tempcr*(tempbr*tempci + tempbi)
            tempai = tempcr*(tempbi*tempci - tempbr)
c     normalize
         endif
         do n = 1, nb
            tempbr = br(n)*tempar - bi(n)*tempai
            bi(n) = br(n)*tempai + bi(n)*tempar
            br(n) = tempbr
         end do
         return 
c     two-term ascending series for small z
      endif
      tempar = 1.0
      tempai = 0.0
      tempcr = 0.25*(x*x - y*y)
      tempci = 0.5*x*y
      br(1) = 1.0 - sign1*tempcr
      bi(1) = -sign1*tempci
      if (nb /= 1) then
         do n = 2, nb
            tempbr = (tempar*x - tempai*y)/(n + n - 2)
            tempai = (tempar*y + tempai*x)/(n + n - 2)
            tempar = tempbr
            tempbr = n
            br(n) = tempar*(1.0 - sign1*tempcr/tempbr) + tempai*tempci/
     1         tempbr
            bi(n) = tempai*(1.0 - sign1*tempcr/tempbr) - tempar*tempci/
     1         tempbr
         end do
      endif
      return 
      end subroutine beslci


c
      subroutine besselj(lmax, lmin, nx, x, besj, h, nx1, work, mx, wk)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:13   6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer lmax, lmin, nx, nx1
      real h
      integer, dimension(nx1) :: mx
      real, dimension(nx1) :: x
      real, dimension(nx1,lmax - lmin + 1) :: besj
      real, dimension(nx1) :: work
      real, dimension(nx1,2) :: wk
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: l, i
C-----------------------------------------------
c---------------------
c  This version uses linear interpolation on Bessel function table.
c  It should be faster, but probably less accurate than the older version
c----------------------
c---------------
c   bessel functions of first kind at x(nx) stored in
c   besj(nx,lmax-lmin+1); order from lmin to lmax
c        i.e., besj(nx,1) is besj(x) of order lmin
c              besj(nx,lmax-lmin+1) is besj(x) of order lmax
c   lmin and lmax must be positive; lmax.ge.lmin
c  x(nx) are assumed ge.0.
c  nx1 is dimension of x,work,mx and first dimension of besj and wk exactly as
c    specified in the calling program
c  h is interval width of Bessel function table.
c  work,mx,wk are working areas; mx is integer
c------------------
 
      do l = lmin, lmax
         call besfun (l, nx, nx1, x, work, h, mx, wk)
         besj(:nx,l-lmin+1) = work(:nx)
      end do
      return 
      end subroutine besselj



c
      subroutine bestab(lmx, lmn, narg, darg, arg0, bestb, wk1, wk2)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  11:00:13   6/14/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer lmx, lmn, narg
      real darg, arg0
      real, dimension(narg,lmx - lmn + 1) :: bestb
      real, dimension(lmx + 1) :: wk1, wk2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, ncalc, j
      real :: x, y
C-----------------------------------------------
c--------------------------
c   Bessel [J(x)] function table generator
c   lmx is maximum order
c   lmn is minimum order
c   narg is dimension of argument of bessel functions
c   darg is increment of each argument
c   arg0 is the value of first argument
c   bestb(narg,nl) contains the bessel function table of narg
c    arguments from order lmn to lmx
c-------------------------
      do i = 1, narg
         x = arg0 + (i - 1)*darg
         y = 0.
         call beslci (x, y, lmx + 1, 0, wk1, wk2, ncalc)
         bestb(i,:) = wk1(lmn+1:lmx+1)
      end do
      return 
      end subroutine bestab






