subroutine aptbanc (au, av, bu, bv, cu, cv, np, tol, & bdu, bdv, du, dv, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTBANC c c call aptbanc (au, av, bu, bv, cu, cv, np, tol, c & bdu, bdv, du, dv, nerr) c c Version: aptbanc Updated 1990 November 27 14:00. c aptbanc Originated 1990 March 8 17:00. 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 input data, the bisector c bd = (bdu, bdv) of the angle "abc" formed bv the points c a = (au, av), b = (bu, bv), and c = (cu, cv) in the uv plane, c and point d = (du, dv), the intercept of the bisector on c the line "ca". If points "a", "b" and "c" are colinear, c vector "bd" will be zero, and point "d" will be point "b". c Flag nerr indicates any input error, if not zero. c c History: 1990 March 30. Fixed array index error which affected problems c with np .gt. 64. c c Input: au, av, bu, bv, cu, cv, np, tol. c c Output: bdu, bdv, du, dv, nerr. c c Calls: aptvdic, aptvuac c c c Glossary: c c au, av Input The u and v coordinates of point "a". Size np. c c bdu, bdv Output The u and v components of the vector "bd" which c bisects angle "abc", and connects points "b" and "d". c Size np. c c bu, bv Input The u and v coordinates of point "b". Size np. c c cu, cv Input The u and v coordinates of point "c". Size np. c c du, dv Output The u and v coordinates of point "d" on line "ca". c The intercept of bisector "bd" on line "ca". 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 au, av, bu, bv, cu, cv, c bdu, bdv, du, dv. 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 "a". dimension au (1) c---- Coordinate v of point "a". dimension av (1) c---- Component u of vector "bd". dimension bdu (1) c---- Component v of vector "bd". dimension bdv (1) c---- Coordinate u of point "b". dimension bu (1) c---- Coordinate v of point "b". dimension bv (1) c---- Coordinate u of point "c". dimension cu (1) c---- Coordinate v of point "c". dimension cv (1) c---- Coordinate u of point "d". dimension du (1) c---- Coordinate v of point "d". dimension dv (1) c.... Local variables. c---- Distance from "a" to "b". common /laptbanc/ distab (64) c---- Distance from "b" to "c". common /laptbanc/ distbc (64) c---- Estimated error in du. common /laptbanc/ duerr c---- Estimated error in dv. common /laptbanc/ dverr c---- Temporary factor. common /laptbanc/ fact c---- A very small number. common /laptbanc/ fuz c---- Component u of unit vector along "ab". common /laptbanc/ habu (64) c---- Component v of unit vector along "ab". common /laptbanc/ habv (64) c---- Component u of unit vector along "bc". common /laptbanc/ hbcu (64) c---- Component v of unit vector along "bc". common /laptbanc/ hbcv (64) c---- Component u of "uab" - "ubc". common /laptbanc/ hu (64) c---- Component v of "uab" - "ubc". common /laptbanc/ hv (64) c---- Index in arrays. common /laptbanc/ n c---- First index of subset of data. common /laptbanc/ n1 c---- Last index of subset of data. common /laptbanc/ n2 c---- Index in external array. common /laptbanc/ nn c---- Size of current subset of data. common /laptbanc/ ns c---- Magnitude of a vector. common /laptbanc/ vlen (64) cbugc***DEBUG begins. cbug 9901 format (/ 'aptbanc finding bisector of angle abc. tol=',1pe22.14) cbug 9902 format (i3,' au,av=',1p2e22.14 / cbug & ' bu,bv=',1p2e22.14 / cbug & ' cu,cv=',1p2e22.14) cbug write ( 3, 9901) tol cbug write ( 3, 9902) (n, au(n), av(n), bu(n), bv(n), cbug & 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 subsets of data. 110 ns = n2 - n1 + 1 c.... Find the unit vector "uab" along line "ab", distance distab. call aptvdic (au(n1), av(n1), & bu(n1), bv(n1), ns, tol, & habu, habv, distab, nerr) call aptvuac (habu, habv, ns, 0., vlen, nerr) c.... Find the unit vector "ubc" along line "bc", distance distbc. call aptvdic (bu(n1), bv(n1), & cu(n1), cv(n1), ns, tol, & hbcu, hbcv, distbc, nerr) call aptvuac (hbcu, hbcv, ns, 0., vlen, nerr) c.... Find the difference between vectors "uab" and "ubc". call aptvdic (habu, habv, & hbcu, hbcv, ns, tol, & hu, hv, vlen, nerr) c.... Find the angle bisector "bd". c---- Loop over subset of data. do 120 n = 1, ns nn = n + n1 - 1 fact = distab(n) * distbc(n) / & (distab(n) + distbc(n) + fuz) bdu(nn) = fact * hu(n) bdv(nn) = fact * hv(n) c---- End of loop over subset of data. 120 continue c.... Find the intercept point "d". c---- Loop over subset of data. do 130 n = 1, ns nn = n + n1 - 1 fact = distab(n) + distbc(n) + fuz du(nn) = (distab(n) * cu(nn) + distbc(n) * au(nn)) / fact dv(nn) = (distab(n) * cv(nn) + distbc(n) * av(nn)) / fact c---- End of loop over subset of data. 130 continue c.... See if truncation to zero is allowed. c---- Truncation is allowed. if (tol .gt. 0.0) then c---- Loop over subset of data. do 140 n = 1, ns nn = n + n1 - 1 fact = distab(n) + distbc(n) + fuz duerr = tol * (distab(n) * abs (cu(nn)) + & distbc(n) * abs (au(nn))) / fact dverr = tol * (distab(n) * abs (cv(nn)) + & distbc(n) * abs (av(nn))) / fact if (abs (du(nn)) .lt. duerr) then du(nn) = 0.0 endif if (abs (dv(nn)) .lt. dverr) then dv(nn) = 0.0 endif c---- End of loop over subset of data. 140 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 9903 format (/ 'aptbanc results:' / cbug & (i3,' bdu,bdv=',1p2e22.14 / cbug & ' du,dv=',1p2e22.14)) cbug write ( 3, 9903) (n, bdu(n), bdv(n), cbug & du(n), dv(n), n = 1, np) cbugc***DEBUG ends. 210 return c.... End of subroutine aptbanc. (+1 line.) end UCRL-WEB-209832