subroutine aptlook (xlook, x, nx, incr, intx, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTLOOK
c
c     call aptlook (xlook, x, nx, incr, intx, nerr)
c
c     Version:  aptlook  Updated    1990 August 28 18:00.
c               aptlook  Originated 1990 August 28 18:00.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To find the interval intx containing xlook, in the table
c               containing nx values of x, with an increment incr between
c               successive values of x in memory.
c               A binary search method is used.
c               Flag nerr indicates any input error, if not zero.
c
c     Input:    xlook, x, nx, incr.
c
c     Output:   intx, nerr.
c
c     Glossary:
c
c     incr      Input    Increment between successive values of x in memory.
c
c     intx      Output   The number of the table interval containing xlook,
c                          or nearest to xlook, if xlook is outside the table
c                          limits.  Defining xx(k) = x(1+incr*(k-1)):
c                          For a table with increasing values of x:
c                            intx = 1      if             xlook < xx(2).
c                            intx = n      if xx(n)    <= xlook < xx(n+1).
c                            intx = nx - 1 if xx(nx-1) <= xlook.
c                          For a table with decreasing values of x:
c                            intx = 1      if             xlook > xx(2).
c                            intx = n      if xx(n)    >= xlook > xx(n+1).
c                            intx = nx - 1 if xx(nx-1) >= xlook.
c                          Note that the intx'th table interval is bounded by
c                          x(1+incr*(intx-1)) and x(1+incr*intx).
c
c     nerr      Output   Indicates an input error, if not zero.
c                          1 if nx is not 2 or more.
c
c     nx        Input    The number of values of x.  The number of table
c                          intervals is nx - 1.  The index of the nx'th
c                          value of x is 1 + incr * (nx - 1).
c
c     x         Input    Table of values, starting at x(1), with an increment
c                          of incr, and ending at x(1+incr*(nx-1)).
c                          Values of x must be monotonic, either increasing
c                          or decreasing.
c
c     xlook     Input    Table look-up argument.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Dimensioned arguments.

c---- Table.
      dimension x       (1)

c.... Local variables.

c---- Index of intx'th value of x.
      common /laptlook/ index
c---- Minimum possible intx.
      common /laptlook/ imin
c---- Maximum possible intx.
      common /laptlook/ imax
c---- Direction of increase in x.
      common /laptlook/ xsign
cbugc***DEBUG begins.
cbugc---- Index in x.
cbug      common /laptlook/ n
cbug 9901 format (/ 'aptlook binary table look-up.  xlook=',1pe22.14)
cbug 9902 format (i5,' x=',1pe22.14, '  index=',i5)
cbug      write ( 3, 9901) xlook
cbug      do 110 n = 1, nx
cbug        index = 1 + incr * (n - 1)
cbug        write ( 3, 9902) n, x(index), index
cbug  110 continue
cbugc***DEBUG ends.

c.... Test for input errors.

      nerr = 0

      if (nx .le. 1) then
        nerr = 1
        go to 210
      endif

c.... Find the table interval containing xlook.

      xsign = sign (1.0, x(1+incr*(nx-1)) - x(1))

      imin = 1
      imax = nx

  120 intx = (imin + imax) / 2

      index = 1 + incr * (intx - 1)

      if (xsign * (x(index) - xlook) .gt. 0.0) then
        imax = intx
        if (imax .ge. 2) go to 120
      else
        imin = intx
        if ((imax - imin) .gt. 1) go to 120
      endif
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptlook results.  intx=',i5)
cbug      write ( 3, 9903) intx
cbugc***DEBUG ends.

  210 return

c.... End of subroutine aptlook.      (+1 line.)
      end

UCRL-WEB-209832