subroutine apttran (ax, ay, az, px, py, pz, np, tol, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTTRAN c c call apttran (ax, ay, az, px, py, pz, np, tol, nerr) c c Version: apttran Updated 1990 December 3 16:20. c apttran Originated 1989 November 2 14:10. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To translate the origin to the point a = (ax, ay, az), c by subtracting the vector "a" from the np points c p = (px, py, pz). New coordinates less than the estimated error c in their calculation, based on tol, will be truncated to zero. c Flag nerr indicates any input error. c c Input: ax, ay, az, px, py, pz, np, tol. c c Output: px, py, pz, nerr. c c Glossary: c c ax,ay,az Input The x, y z components of vector "a", to be c subtracted from points "p". c c nerr Output Indicates an input error, if not 0. c 1 if np is not positive. c c np Input Number of points (px, py, pz). c c tol Input Numerical tolerance limit. c On Cray computers, recommend 1.e-5 to 1.e-11. c c px,py,pz In/Out The x, y, z coordinates of point "p". Size np. c Truncated to zero if smaller than the estimated c error in their calculation, based on tol. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. c---- Coordinate x of a point. dimension px (1) c---- Coordinate y of a point. dimension py (1) c---- Coordinate z of a point. dimension pz (1) c.... Local variables. c---- Index in px, py, pz. common /lapttran/ n c---- Estimated truncation error in px. common /lapttran/ pxerr c---- Estimated truncation error in py. common /lapttran/ pyerr c---- Estimated truncation error in pz. common /lapttran/ pzerr c---- Square of length of (ax, ay, az). common /lapttran/ vlen2 cbugc***DEBUG begins. cbug 9901 format (/ 'apttran finding translated points. New origin at:' / cbug & ' ax,ay,az=',1p3e22.14) cbug 9902 format (/ ' initial values:' / cbug & (i3,' px,py,pz=',1p3e22.14)) cbug write ( 3, 9901) ax, ay, az cbug write ( 3, 9902) (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, '(/ "apttran fatal. bad np=",i3)') np cbugc***DEBUG ends. go to 210 endif vlen2 = ax**2 + ay**2 + az**2 c---- Translate points "p". if (vlen2 .gt. tol**2) then c---- No truncation. if (tol .le. 0.0) then c---- Loop over points. do 110 n = 1, np px(n) = px(n) - ax py(n) = py(n) - ay pz(n) = pz(n) - az c---- End of loop over points. 110 continue c---- Truncate small components to zero. else c---- Loop over points. do 120 n = 1, np pxerr = tol * (abs (px(n)) + abs (ax)) pyerr = tol * (abs (py(n)) + abs (ay)) pzerr = tol * (abs (pz(n)) + abs (az)) px(n) = px(n) - ax py(n) = py(n) - ay pz(n) = pz(n) - az if (abs (px(n)) .lt. pxerr) then px(n) = 0.0 endif if (abs (py(n)) .lt. pyerr) then py(n) = 0.0 endif if (abs (pz(n)) .lt. pzerr) then pz(n) = 0.0 endif c---- End of loop over points. 120 continue c---- Tested tol. endif c---- Tested length of vector "a". endif cbugc***DEBUG begins. cbug 9903 format (/ 'apttran results:' / cbug & (i3,' px,py,pz=',1p3e22.14)) cbug write ( 3, 9903) (n, px(n), py(n), pz(n), n = 1, np) cbugc***DEBUG ends. 210 return c.... End of subroutine apttran. (+1 line.) end UCRL-WEB-209832