subroutine aptprop (ax, ay, az, bx, by, bz, px, py, pz, np, tol,
& qx, qy, qz, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTPROP
c
c call aptprop (ax, ay, az, bx, by, bz, px, py, pz, np, tol,
c & qx, qy, qz, nerr)
c
c Version: aptprop Updated 1990 October 5 11:00.
c aptprop Originated 1990 October 5 11:00.
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) onto the plane through
c point a = (ax, ay, az), with normal vector b = (bx, by, bz).
c The projection of each point "p" is point q = (qx, qy, qz).
c
c Flag nerr indicates any input error.
c
c Input: ax, ay, az, bx, by, bz, px, py, pz, np, tol.
c
c Output: qx, qy, qz, nerr.
c
c Calls: aptmopv, aptrotv, apttran, aptvunb
c
c
c Glossary:
c
c ax,ay,az Input The x, y, z coordinates of a point in the projection
c plane.
c
c bx,by,bz Input The x, y, z components of a vector normal to the
c projection plane.
c
c nerr Output Indicates an input error, if not 0.
c 1 if np is not positive.
c 2 if the vector "b" is too short, based on tol.
c
c np Input Size of arrays px, py, pz, qx, qy, qz.
c The number of points projected.
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 projection of the point
c "p" on the projection surface, which is a plane
c through point "a" with normal vector "b".
c Size np.
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---- Index in arrays.
common /laptprop/ n
c---- Rotation matrix.
common /laptprop/ rotm (3,3)
c---- Component x of unit vector "ub".
common /laptprop/ ubx
c---- Component y of unit vector "ub".
common /laptprop/ uby
c---- Component z of unit vector "ub".
common /laptprop/ ubz
c---- Length of axis vector "b".
common /laptprop/ vlenb
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptprop projecting points onto a plane. tol=',
cbug & 1pe13.5 /
cbug & ' The plane is through point a with normal vector b:' /
cbug & ' ax,ay,az= ',1p3e22.14 /
cbug & ' bx,by,bz= ',1p3e22.14 /
cbug & ' The points projected are:' /
cbug & (i3,' px,py,pz=',1p3e22.14))
cbug write ( 3, 9901) tol, ax, ay, az, bx, by, bz,
cbug & (n, px(n), py(n), pz(n), n = 1, np)
cbugc***DEBUG ends.
c.... Initialize.
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.... Find the length of the normal vector "b".
call aptvunb (bx, by, bz, 1, 0., ubx, uby, ubz, vlenb, nerr)
c---- Vector "b" is too short.
if (vlenb .le. tol) then
nerr = 2
cbugc***DEBUG begins.
cbug write ( 3, '(/ "Vector b is too short.")')
cbugc***DEBUG ends.
go to 210
c---- Tested vlenb.
endif
c.... Find the rotation matrix to rotate vector "b" onto the z axis.
call aptrotv (bx, by, bz, 0., 0., 1., tol, rotm, nerr)
c.... Initialize the 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.... Rotate the normal vector "b" to the z axis.
call aptmopv (rotm, 0, 0., 0., 0., qx, qy, qz, np, tol, nerr)
c.... Project in the direction of the normal vector.
c---- Loop over data.
do 120 n = 1, np
qz(n) = 0.0
c---- End of loop over data.
120 continue
c.... Restore the initial z axis.
call aptmopv (rotm, 1, 0., 0., 0., qx, qy, qz, np, tol, nerr)
c.... Restore the original origin.
call apttran (-ax, -ay, -az, qx, qy, qz, np, tol, nerr)
cbugc***DEBUG begins.
cbug 9902 format (/ 'aptprop 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 aptprop. (+1 line.)
end
UCRL-WEB-209832