subroutine aptpros (ax, ay, az, rsph, px, py, pz, np, tol,
& qx, qy, qz, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTPROS
c
c call aptpros (ax, ay, az, rsph, px, py, pz, np, tol,
c & qx, qy, qz, nerr)
c
c Version: aptpros Updated 1990 November 29 10:50.
c aptpros Originated 1990 October 2 16:30.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To project the np points p = (px, py, pz) radially onto the
c sphere of radius rsph, centered at point a = (ax, ay, az).
c The projected points are returned as q = (qx, qy, qz).
c Flag nerr indicates any input error.
c
c Input: ax, ay, az, rsph, px, py, pz, np, tol.
c
c Output: qx, qy, qz, nerr.
c
c Calls: apttran
c
c Glossary:
c
c ax,ay,az Input The x, y, z coordinates of the center of the projection
c sphere of radius rsph.
c
c nerr Output Indicates an input error, if not 0.
c 1 if np is not positive.
c
c np Input Size of arrays px, py, pz, qx, qy, qz.
c
c px,py,pz Input The x, y, z coordinates of point "p". Size np.
c
c qx,qy,qz Output The x, y, z coordinates of the points projected from
c points "p" radially onto the sphere of radius rsph
c centered at point "a". Size np.
c Points "p" that coincide with point "a", based on
c tol, will be assigned very large "q" coordinates.
c
c rsph Input The radius of the projection sphere centered at point
c "a".
c
c tol Input Numerical tolerance limit.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Coordinate x of point "p".
dimension px (1)
c---- Coordinate y of point "p".
dimension py (1)
c---- Coordinate z of point "p".
dimension pz (1)
c---- Coordinate x of point "q".
dimension qx (1)
c---- Coordinate y of point "q".
dimension qy (1)
c---- Coordinate z of point "q".
dimension qz (1)
c.... Local variables.
c---- A very big number.
common /laptpros/ big
c---- Distance between points "a" and "p".
common /laptpros/ dap
c---- A very small number.
common /laptpros/ fuz
c---- Index in arrays.
common /laptpros/ n
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptpros projecting onto the sphere at:' /
cbug & ' ax,ay,az= ',1p3e22.14 /
cbug & ' with radius rsph=',1pe22.14 /
cbug & ' The points projected are:' /
cbug & (i3,' px,py,pz=',1p3e22.14))
cbug write ( 3, 9901) ax, ay, az, rsph,
cbug & (n, px(n), py(n), pz(n), n = 1, np)
cbugc***DEBUG ends.
c.... Initialize.
c---- A very big number.
big = 1.e+99
c---- A very small number.
fuz = 1.e-99
nerr = 0
c.... Test for input errors.
if (np .le. 0) then
nerr = 1
cbugc***DEBUG begins.
cbug write ( 3, '(/ "np = 0")')
cbugc***DEBUG ends.
go to 210
endif
c.... Initialize projected points "q".
c---- Loop over data.
do 110 n = 1, np
qx(n) = px(n)
qy(n) = py(n)
qz(n) = pz(n)
c---- End of loop over data.
110 continue
c.... Move the origin to point "a".
call apttran (ax, ay, az, qx, qy, qz, np, tol, nerr)
c.... Project the points onto the sphere of radius rsph centered at point "a".
c---- Loop over data.
do 120 n = 1, np
dap = sqrt (qx(n)**2 + qy(n)**2 + qz(n)**2)
qx(n) = rsph * qx(n) / (dap + fuz)
qy(n) = rsph * qy(n) / (dap + fuz)
qz(n) = rsph * qz(n) / (dap + fuz)
if (dap .le. tol) then
qx(n) = big
qy(n) = big
qz(n) = big
endif
c---- End of loop over data.
120 continue
c.... Restore the origin to its original coordinates.
call apttran (-ax, -ay, -az, qx, qy, qz, np, tol, nerr)
cbugc***DEBUG begins.
cbug 9902 format (/ 'aptpros results:' /
cbug & (i3,' qx,qy,qz=',1p3e22.14))
cbug write ( 3, 9902) (n, qx(n), qy(n), qz(n), n = 1, np)
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptpros. (+1 line.)
end
UCRL-WEB-209832