subroutine aptintp (au, av, bu, bv, lopt, cu, cv, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTINTP
c
c call aptintp (au, av, bu, bv, lopt, cu, cv, nerr)
c
c Version: aptintp Updated 1993 June 3 11:50.
c aptintp Originated 1993 June 3 11:50.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: Given the two points a = (au, av) and b = (bu, bv) in the uv
c plane, and the u coordinate cu of point c = (cu, cv), to find
c the v coordinate cv of point "c" by interpolation or
c extrapolation. Option lopt determines the types of u and v
c axes: 0 for linear-linear, 1 for linear-log, 2 for log-linear
c and 3 for log-log, respectively.
c Flag nerr indicates extrapolation, if -1, or an input error,
c if positive.
c
c Input: au, av, bu, bv, lopt, cu.
c
c Output: cv, nerr.
c
c Glossary:
c
c au, av Input The u and v coordinates of point "a" in the uv plane.
c
c bu, bv Input The u anv v coordinates of point "b" in the uv plane.
c
c cu Input The u coordinate of point "c" in the uv plane.
c
c cv Output The v coordinate of point "c" in the uv plane, to be
c found by linear interpolation or extrapolation using
c points "a" and "b".
c The value -1.e99 is returned if nerr is not zero.
c
c lopt Input Indicates the type of u and v axes to be used for
c linear interpolation or extrapolation:
c 0 if u is linear, v is linear.
c v = p + q * u
c 1 if u is linear, v is logarithmic.
c ln (v) = p + q * u
c 2 if u is logarithmic, v is linear.
c v = p + q * ln (u)
c 3 if u is logarithmic, v is logarithmic.
c ln (v) = p + q * ln (u)
c
c nerr Output Indicates an input error, if positive.
c 1 if lopt is not between 0 and 3.
c 2 if lopt is 2 or 3, and au, bu or cu is not
c positive.
c 3 if lopt is 1 or 3, and av or bv is not positive.
c 4 if au = bu, and av is not equal to bv, or cu is not
c equal to au.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Local variables.
c---- Natural log of au.
common /laptintp/ fau
c---- Natural log of bu.
common /laptintp/ fbu
c---- Natural log of cu.
common /laptintp/ fdu
c---- Natural log of av.
common /laptintp/ fav
c---- Natural log of bv.
common /laptintp/ fbv
c---- Natural log of cv.
common /laptintp/ fcv
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptintp interpolating between two points. lopt=',i2 /
cbug & 'au,av=',1p2e22.14 /
cbug & 'bu,bv=',1p2e22.14 /
cbug & 'cu =',1pe22.14)
cbug write ( 3, 9901) lopt, au, av, bu, bv, cu
cbugc***DEBUG ends.
c.... initialize.
nerr = 0
cv = -1.e99
c.... Test for lopt between 0 and 3.
if ((lopt .lt. 0) .or. (lopt .gt. 3)) then
nerr = 1
go to 210
endif
c.... See if cu is at au or at bu, or outside the interval (au, bu).
c.... It is OK if point "a" coincides with point "b", if cu = au.
if (cu .eq. au) then
if (au .eq. bu) then
if (av .ne. bv) then
nerr = 4
go to 210
endif
endif
cv = av
go to 210
elseif (cu .eq. bu) then
cv = bv
go to 210
elseif ((cu - au) * (cu - bu) .gt. 0.0) then
nerr = -1
endif
c.... Test for indeterminate slope.
if (au .eq. bu) then
nerr = 4
go to 210
endif
c.... Interpolate or extrapolate to find cv, if no input errors.
if (lopt .eq. 0) then
cv = av + (bv - av) *(cu - au) / (bu - au)
elseif (lopt .eq. 1) then
if ((av .le. 0.0) .or. (bv .le. 0.0)) then
nerr = 3
go to 210
endif
fav = log (av)
fbv = log (bv)
fcv = fav + (fbv - fav) *(cu - au) / (bu - au)
cv = exp (fcv)
elseif (lopt .eq. 2) then
if ((au .le. 0.0) .or. (bu .le. 0.0) .or.
& (cu .le. 0.0)) then
nerr = 2
go to 210
endif
fau = log (au)
fbu = log (bu)
fcu = log (cu)
cv = av + (bv - av) *(fcu - fau) / (fbu - fau)
elseif (lopt .eq. 3) then
if ((au .le. 0.0) .or. (bu .le. 0.0) .or.
& (cu .le. 0.0)) then
nerr = 2
go to 210
endif
if ((av .le. 0.0) .or. (bv .le. 0.0)) then
nerr = 3
go to 210
endif
fau = log (au)
fbu = log (bu)
fcu = log (cu)
fav = log (av)
fbv = log (bv)
fcv = fav + (fbv - fav) *(fcu - fau) / (fbu - fau)
cv = exp (fcv)
endif
210 continue
cbugc***DEBUG begins.
cbug 9902 format (/ 'aptintp results: nerr=',i3,' cv=',1pe22.14 )
cbug write ( 3, 9902) nerr, cv
cbugc***DEBUG ends.
return
c.... End of subroutine aptintp. (+1 line.)
end
UCRL-WEB-209832