subroutine aptvplc (au, av, bu, bv, np, tol, cu, cv, vlen, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTVPLC
c
c call aptvplc (au, av, bu, bv, np, tol, cu, cv, vlen, nerr)
c
c Version: aptvplc Updated 1990 November 26 10:00.
c aptvplc Originated 1989 December 28 13:20.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To find the vector c = (cu, cv) normal to the line defined by
c the two points a = (au, av), b = (bu, bv), and in the uv plane,
c for each of the np sets of points "a" and "b". The directions
c u, v, w are orthogonal. The magnitude vlen of the normal vector
c "c" is equal to the length of the line segment "ab". If vlen is
c zero, the points "a" and "b" are congruent. By convention,
c the direction of the normal vector is from right to left,
c relative to the direction from "a" to "b" in the uv plane.
c The components of "c" will be truncated to zero, if less than
c the estimated numerical error in their calculation, based on
c tol. Flag nerr indicates any input error, if not zero.
c
c Input: au, av, bu, bv, np, tol.
c
c Output: cu, cv, vlen, nerr.
c
c Glossary:
c
c au, av Input The u and v coordinates of point "a". Size np.
c
c bu, bv Input The u and v coordinates of point "b". Size np.
c
c cu, cv Output The u and v components of normal vector "c".
c May be truncated to zero, if less than the estimated
c numerical error in their calculation. See tol.
c
c nerr Output Indicates an input error, if not 0.
c 1 if np is not positive.
c
c np Input The number of sets of points "a" and "b" for which the
c normal vector "c" is to be calculated.
c Must be positive.
c
c tol Input Numerical tolerance limit for cu, cv.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
c vlen Output The magnitude of the normal vector "c". Size np.
c Zero if points "a" and "b" are congruent.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Coordinate u of input point "a".
dimension au (1)
c---- Coordinate v of input point "a".
dimension av (1)
c---- Coordinate u of input point "b".
dimension bu (1)
c---- Coordinate v of input point "b".
dimension bv (1)
c---- Component u of normal vector "c".
dimension cu (1)
c---- Component v of normal vector "c".
dimension cv (1)
c---- Magnitude of normal vector "c".
dimension vlen (1)
c.... Local variables.
c---- Index in arrays.
common /laptvplc/ n
c---- Estimated error in cu.
common /laptvplc/ cuerr
c---- Estimated error in cv.
common /laptvplc/ cverr
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptvplc finding normal vector to line',
cbug & ' through points:' /
cbug & (i3,' au,av=',1p2e22.14 /
cbug & ' bu,bv=',1p2e22.14))
cbug write ( 3, 9901) (n, au(n), av(n), bu(n), bv(n), n = 1, np)
cbugc***DEBUG ends.
c.... Initialize.
nerr = 0
c.... Test for input errors.
if (np .le. 0) then
nerr = 1
go to 210
endif
c.... Find the components of the normal vector "c", which is leftward from
c.... the direction of the line "ab" in the uv plane.
c---- Loop over lines.
do 110 n = 1, np
cu(n) = av(n) - bv(n)
cv(n) = bu(n) - au(n)
c---- End of loop over lines.
110 continue
c.... See if the components should be tested for numerical error.
c---- Test for numerical error.
if (tol .gt. 0.0) then
c---- Loop over normal vectors.
do 120 n = 1, np
cuerr = tol * (abs (av(n)) + abs (bv(n)))
if (abs (cu(n)) .lt. cuerr) then
cu(n) = 0.0
endif
cverr = tol * (abs (au(n)) + abs (bu(n)))
if (abs (cv(n)) .lt. cverr) then
cv(n) = 0.0
endif
c---- End of loop over normal vectors.
120 continue
c---- Tested tol.
endif
c.... Find the magnitudes of the normal vectors.
c---- Loop over normal vectors.
do 130 n = 1, np
vlen(n) = sqrt (cu(n)**2 + cv(n)**2)
c---- End of loop over normal vectors.
130 continue
cbugc***DEBUG begins.
cbug 9902 format (/ 'aptvplc results:' /
cbug & (i3,' vlen= ',1pe22.14 /
cbug & ' cu,cv=',1p2e22.14))
cbug write ( 3, 9902) (n, vlen(n), cu(n), cv(n), n = 1, np)
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptvplc. (+1 line.)
end
UCRL-WEB-209832