subroutine apttrac (au, av, pu, pv, np, tol, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTTRAC c c call apttrac (au, av, pu, pv, np, tol, nerr) c c Version: apttrac Updated 1990 December 3 16:20. c apttrac Originated 1990 January 4 12:00. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To translate the origin to the 2-D point a = (au, av), c by subtracting the vector "a" from the np 2-D points c p = (pu, pv). 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: au, av, pu, pv, np, tol. c c Output: pu, pv, nerr. c c Glossary: c c nerr Output Indicates an input error, if not 0. c 1 if np is not positive. c 2 if the magnitude of (au, av) is no greater than c tol. c c np Input Number of 2-D points (pu, pv). c c tol Input Numerical tolerance limit. c On Cray computers, recommend 1.e-5 to 1.e-11. c c pu, pv In/Out The u and v coordinates of 2-D point "p". c 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 u of a point. dimension pu (1) c---- Coordinate v of a point. dimension pv (1) c.... Local variables. c---- Index in pu, pv. common /lapttrac/ n c---- Estimated truncation error in pu. common /lapttrac/ puerr c---- Estimated truncation error in pv. common /lapttrac/ pverr c---- Square of length of (au, av). common /lapttrac/ vlen2 cbugc***DEBUG begins. cbug 9901 format (/ 'apttrac translating points. New origin at:' / cbug & ' au,av=',1p2e22.14) cbug write ( 3, 9901) au, av cbugc***DEBUG ends. c.... Initialize. nerr = 0 c.... Test for input errors. if (np .le. 0) then nerr = 1 go to 210 endif vlen2 = au**2 + av**2 if (vlen2 .le. tol**2) then nerr = 2 go to 210 endif cbugc***DEBUG begins. cbug 9902 format (/ ' initial values.' / cbug & ' n pu',20x,'pv',20x / (i5,1p2e22.14)) cbug write ( 3, 9902) (n, pu(n), pv(n), n = 1, np) cbugc***DEBUG ends. c.... Translate points. c---- No truncation. if (tol .le. 0.0) then c---- Loop over points. do 110 n = 1, np pu(n) = pu(n) - au pv(n) = pv(n) - av c---- End of loop over points. 110 continue c---- Truncate small components to zero. else c---- Loop over points. do 120 n = 1, np puerr = tol * (abs (pu(n)) + abs (au)) pverr = tol * (abs (pv(n)) + abs (av)) pu(n) = pu(n) - au pv(n) = pv(n) - av if (abs (pu(n)) .lt. puerr) then pu(n) = 0.0 endif if (abs (pv(n)) .lt. pverr) then pv(n) = 0.0 endif c---- End of loop over points. 120 continue c---- Tested tol. endif cbugc***DEBUG begins. cbug 9903 format (/ ' final values.' / cbug & ' n pu',20x,'pv',20x / (i5,1p2e22.14)) cbug write ( 3, 9903) (n, pu(n), pv(n), n = 1, np) cbugc***DEBUG ends. 210 return c.... End of subroutine apttrac. (+1 line.) end UCRL-WEB-209832