subroutine aptrloc (wa, wb, wc, au, av, bu, bv, cu, cv, np, tol, & pu, pv, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTRLOC c c call aptrloc (wa, wb, wc, au, av, bu, bv, cu, cv, np, tol, c & pu, pv, nerr) c c Version: aptrloc Updated 1990 December 3 14:20. c aptrloc Originated 1990 May 16 17:40. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To find, for each of np sets of vertex weights wa, wb and wc, c the point p = (pu, pv), interpolated between the vertices c a = (au, av), b = (bu, bv) and c = (cu, cv) of a c triangle in a major plane. c c p = (wa * a + wb * b + wc * c) / (wa + wb + wc). c c Flag nerr indicates any input error. c c Input: wa, wb, wc, au, av, bu, bv, cu, cv, np, tol. c c Output: pu, pv, nerr. c c Calls: None c c Glossary: c c au, av Input The u and v coordinates of vertex "a" of triangle. c Size np. c c bu, bv Input The u and v coordinates of vertex "b" of triangle. c Size np. c c cu, cv Input The u and v coordinates of vertex "c" of triangle. c Size np. 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 wa, wb, wc, au, av, bu, bv, c cu, cv, pu, pv. c c pu, pv Output Interpolated point "p". Size np. Coordinates may be c truncated to zero, if less than the estimated error c in their calculation, based on tol. c c tol Input Numerical tolerance limit. c On Cray computers, recommend 1.e-5 to 1.e-11. c c wa Input Fractional distance of point "p" to vertex "a" from c edge "bc", when normalized. Size np. c c wb Input Fractional distance of point "p" to vertex "b" from c edge "ca", when normalized. Size np. c c wc Input Fractional distance of point "p" to vertex "c" from c edge "ab", when normalized. Size np. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. c---- Cooodinate u of point "a". dimension au (1) c---- Coordinate v of point "a". dimension av (1) c---- Cooodinate u of point "b". dimension bu (1) c---- Coordinate v of point "b". dimension bv (1) c---- Cooodinate u of point "c". dimension cu (1) c---- Coordinate v of point "c". dimension cv (1) c---- Cooodinate u of point "p". dimension pu (1) c---- Coordinate v of point "p". dimension pv (1) c---- Fractional distance to "a" from "bc". dimension wa (1) c---- Fractional distance to "b" from "ca". dimension wb (1) c---- Fractional distance to "c" from "ab". dimension wc (1) c.... Local variables. c---- A very small number. common /laptrloc/ fuz c---- Index in local array. common /laptrloc/ n c---- First index of subset of data. common /laptrloc/ n1 c---- Last index of subset of data. common /laptrloc/ n2 c---- Index in external array. common /laptrloc/ nn c---- Size of current subset of data. common /laptrloc/ ns c---- Estimated error in pu. common /laptrloc/ puerr c---- Estimated error in pv. common /laptrloc/ pverr c---- Sum of wa + wb + wc. common /laptrloc/ sum cbugc***DEBUG begins. cbug 9901 format (/ 'aptrloc interpolating in a triangle.' / cbug & (i3,' wa,wb,wc=',1p3e22.14 / cbug & ' au,av=',1p2e22.14 / cbug & ' bu,bv=',1p2e22.14 / cbug & ' cu,cv=',1p2e22.14)) cbug write (3, 9901) (n, wa(n), wb(n), wc(n), au(n), av(n), cbug & bu(n), bv(n), cu(n), cv(n), n = 1, np) cbugc***DEBUG ends. c.... initialize. c---- A very small number. fuz = 1.e-99 nerr = 0 c.... Test for input errors. if (np .le. 0) then nerr = 1 go to 210 endif c.... Set up the indices of the first subset of data. n1 = 1 n2 = min (np, 64) c.... Loop over the data subsets. 110 ns = n2 - n1 + 1 c.... Find the coordinates of the points. c---- Loop over subset of data. do 120 n = 1, ns nn = n + n1 - 1 sum = wa(nn) + wb(nn) + wc(nn) pu(nn) = (wa(nn) * au(nn) + wb(nn) * bu(nn) + wc(nn) * cu(nn)) / & (sum + fuz) pv(nn) = (wa(nn) * av(nn) + wb(nn) * bv(nn) + wc(nn) * cv(nn)) / & (sum + fuz) c---- End of loop over subset of data. 120 continue c.... See if truncation allowed. c---- Truncation to zero allowed. if (tol .gt. 0.0) then c---- Loop over subset of data. do 130 n = 1, ns nn = n + n1 - 1 sum = wa(nn) + wb(nn) + wc(nn) puerr = tol * (abs (wa(nn) * au(nn)) + & abs (wb(nn) * bu(nn)) + & abs (wc(nn) * cu(nn))) / (sum + fuz) pverr = tol * (abs (wa(nn) * av(nn)) + & abs (wb(nn) * bv(nn)) + & abs (wc(nn) * cv(nn))) / (sum + fuz) if (abs (pu(nn)) .lt. puerr) then pu(nn) = 0.0 endif if (abs (pv(nn)) .lt. pverr) then pv(nn) = 0.0 endif c---- End of loop over subset of data. 130 continue c---- Tested tol. endif c.... See if all data subsets are done. c---- Do another subset of data. if (n2 .lt. np) then n1 = n2 + 1 n2 = min (np, n1 + 63) go to 110 endif cbugc***DEBUG begins. cbug 9902 format (/ 'aptrloc results:' / cbug & (i3,' pu,pv=',1p2e22.14)) cbug write ( 3, 9902) (n, pu(n), pv(n), n = 1, np) cbugc***DEBUG ends. 210 return c.... End of subroutine aptrloc. (+1 line.) end UCRL-WEB-209832