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