subroutine aptproc (au, av, rcir, pu, pv, np, tol, qu, qv, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTPROC c c call aptproc (au, av, rcir, pu, pv, np, tol, qu, qv, nerr) c c Version: aptproc Updated 1990 November 29 10:50. c aptproc Originated 1990 October 3 9:30. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To project the np points p = (pu, pv) radially onto the c circle of radius rcir, centered at point a = (au, av). c The projected points are returned as q = (qu, qv). c Flag nerr indicates any input error. c c Input: au, av, rcir, pu, pv, np, tol. c c Output: qu, qv, nerr. c c Calls: apttrac c c Glossary: c c au, av Input The u and v coordinates of the center of the c projection circle of radius rcir. 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 pu, pv, qu, qv. c c pu, pv Input The u and v coordinates of point "p". Size np. c c qu, qv Output The u and v coordinates of the points projected from c points "p" radially onto the circle of radius rcir 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 rcir Input The radius of the projection circle 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 u of point "p". dimension pu (1) c---- Coordinate v of point "p". dimension pv (1) c---- Coordinate u of point "q". dimension qu (1) c---- Coordinate v of point "q". dimension qv (1) c.... Local variables. c---- A very big number. common /laptproc/ big c---- Distance between points "a" and "p". common /laptproc/ dap c---- A very small number. common /laptproc/ fuz c---- Index in arrays. common /laptproc/ n cbugc***DEBUG begins. cbug 9901 format (/ 'aptproc projecting onto the circle at:' / cbug & ' au,av= ',1p2e22.14 / cbug & ' with radius rcir=',1pe22.14 / cbug & ' The points projected are:' / cbug & (i3,' pu,pv=',1p2e22.14)) cbug write ( 3, 9901) au, av, rcir, (n, pu(n), pv(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 qu(n) = pu(n) qv(n) = pv(n) c---- End of loop over data. 110 continue c.... Move the origin to point "a". call apttrac (au, av, qu, qv, np, tol, nerr) c.... Project the points onto the circle of radius rcir centered at point "a". c---- Loop over data. do 120 n = 1, np dap = sqrt (qu(n)**2 + qv(n)**2) qu(n) = rcir * qu(n) / (dap + fuz) qv(n) = rcir * qv(n) / (dap + fuz) if (dap .le. tol) then qu(n) = big qv(n) = big endif c---- End of loop over data. 120 continue c.... Restore the origin to its original coordinates. call apttrac (-au, -av, qu, qv, np, tol, nerr) cbugc***DEBUG begins. cbug 9902 format (/ 'aptproc results:' / cbug & (i3,' qu,qv=',1p2e22.14)) cbug write ( 3, 9902) (n, qu(n), qv(n), n = 1, np) cbugc***DEBUG ends. 210 return c.... End of subroutine aptproc. (+1 line.) end UCRL-WEB-209832