subroutine aptqinc (ktype, ntype, au, av, bu, bv, cu, cv, du, dv,
& pu, pv, np, tol,
& pab, pbc, pcd, pda, dpmin, nloc, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTQINC
c
c call aptqinc (ktype, ntype, au, av, bu, bv, cu, cv, du, dv,
c & pu, pv, np, tol,
c & pab, pbc, pcd, pda, dpmin, nloc, nerr)
c
c Version: aptqinc Updated 1990 November 29 15:30.
c aptqinc Originated 1990 February 21 16:40.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To find, for each of the np sets of input data, the distances
c pab, pbc, pcd and pda from the point p = (pu, pv) to the sides
c of the quadrangle with vertices a = (au, av), b = (bu, bv),
c c = (cu, cv), and d = (du, dv), in counterclockwise order in
c the uv plane, the minimum dpmin of pab, pbc, pcd and pda, and
c whether point "p" is inside the quadrangle or not (flag nloc).
c Option kflag allows the quadrangle shape type to be ignored,
c output, or input, and boomerangs and bowties to be tested.
c The values of pab, pbc, pcd and pda will be truncated to zero,
c if less than the estimated error in their calculation, based on
c tol. Flag nerr indicates any input error.
c
c Input: ktype, ntype, au, av, bu, bv, cu, cv, du, dv, pu, pv, np, tol.
c
c Output: pab, pbc, pcd, pda, dpmin, nloc, nerr.
c
c Calls: aptptlc, aptqvac
c
c
c Glossary:
c
c au, av Input The u, v coordinates of vertex "a" of the quadrangle.
c Size np.
c
c bu, bv Input The u, v coordinates of vertex "b" of the quadrangle.
c Size np.
c
c cu, cv Input The u, v coordinates of vertex "c" of the quadrangle.
c Size np.
c
c dpmin Output Minimum of distances pab, pbc, pcd, pda. Size np.
c Minimum of absolute values of pab, pbc, pcd, pda,
c if point "p" is in a boomerang or bowtie, and
c ktype = 0, 1 or 2. Negative if nloc = 0.
c
c du, dv Input The u, v coordinates of vertex "d" of the quadrangle.
c Size np.
c
c ktype Input Indicates whether ntype is input or output, and
c whether or not cases for which nloc is initially
c zero will be tested to see if the point is actually
c inside a boomerang or bowtie.
c -1 if ntype is not input, and is not to be returned.
c No tests will be made for boomerangs or bowties.
c 0 if ntype is not input, and is not to be returned.
c Tests will be made for boomerangs and bowties.
c 1 if ntype is not input, but will be returned.
c Tests will be made for boomerangs and bowties.
c 2 if ntype is input.
c Tests will be made for boomerangs and bowties.
c
c nerr Output Indicates an input error, if not 0.
c 1 if np is not positive.
c 2 if ktype is not -1, 0, 1 or 2.
c
c nloc Output Indicates the location of point "p" relative to the
c quadrangle "abcd":
c -1 if all quadrangle vertices coincide.
c 0 if point "p" is outside the quadrangle "abcd",
c or is inside, but the quadrangle vertices were
c specified in clockwise order,
c or if ktype = -1, is inside a bowtie or in
c certain areas inside a boomerang.
c 1 if point "p" is inside the quadrangle "abcd",
c and either all four distances pab, pbc, pcd and
c pda are non-negative, or if ktype = 0, 1 or 2,
c the quadrangle is a boomerang or bowtie and the
c distances pass specific tests.
c Size np.
c
c np Input Size of arrays pu, pv, au, av, bu, bv, cu, cv, du, dv,
c pab, pbc, pcd, pda.
c
c ntype I/O? Shape type of quadrangle. Input if ktype = 2.
c Output if ktype = 1. Size np if ktype = 1 or 2.
c 0 if quadrangle is convex.
c 11-14 if quadrangle has just one concave vertex at
c point "a", "b", "c", or "d", resp. (a boomerang).
c 21-24 if quadrangle has just two adjacent concave
c vertices at ends of sides "cd", "da", "ab", or
c "bc", respectively (a bowtie).
c
c pab Output Distance from point "p" to quadrangle edge "ab".
c Truncated to zero, if less than the estimated error
c in its calculation, based on tol.
c Size np.
c
c pbc Output Distance from point "p" to quadrangle edge "bc".
c Truncated to zero, if less than the estimated error
c in its calculation, based on tol.
c Size np.
c
c pcd Output Distance from point "p" to quadrangle edge "cd".
c Truncated to zero, if less than the estimated error
c in its calculation, based on tol.
c Size np.
c
c pda Output Distance from point "p" to quadrangle edge "da".
c Truncated to zero, if less than the estimated error
c in its calculation, based on tol.
c Size np.
c
c pu, pv Input The u and v coordinates of point "p" in the uv plane.
c Size np.
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 quadrangle vertex "a".
dimension au (1)
c---- Coordinate v of quadrangle vertex "a".
dimension av (1)
c---- Coordinate u of quadrangle vertex "b".
dimension bu (1)
c---- Coordinate v of quadrangle vertex "b".
dimension bv (1)
c---- Coordinate u of quadrangle vertex "c".
dimension cu (1)
c---- Coordinate v of quadrangle vertex "c".
dimension cv (1)
c---- Minimum of pab, pbc, pcd, pda.
dimension dpmin (1)
c---- Coordinate u of quadrangle vertex "d".
dimension du (1)
c---- Coordinate v of quadrangle vertex "d".
dimension dv (1)
c---- 1 if point "p" is in quadrangle.
dimension nloc (1)
c---- Shape type of quadrangle.
dimension ntype (1)
c---- Distance from point "p" to edge "ab".
dimension pab (1)
c---- Distance from point "p" to edge "bc".
dimension pbc (1)
c---- Distance from point "p" to edge "cd".
dimension pcd (1)
c---- Distance from point "p" to edge "da".
dimension pda (1)
c---- Coordinate u of point "p".
dimension pu (1)
c---- Coordinate v of point "p".
dimension pv (1)
c.... Local variables.
c---- Dummy argument.
common /laptqinc/ arpa
c---- Dummy argument.
common /laptqinc/ arpb
c---- Dummy argument.
common /laptqinc/ arpc
c---- Dummy argument.
common /laptqinc/ arpd
c---- Dummy argument.
common /laptqinc/ fdmin
c---- Truncation error indicator.
common /laptqinc/ itrunab (64)
c---- Truncation error indicator.
common /laptqinc/ itrunbc (64)
c---- Truncation error indicator.
common /laptqinc/ itruncd (64)
c---- Truncation error indicator.
common /laptqinc/ itrunda (64)
c---- Index in arrays.
common /laptqinc/ n
c---- First index of subset of data.
common /laptqinc/ n1
c---- Last index of subset of data.
common /laptqinc/ n2
c---- Dummy argument.
common /laptqinc/ nlim
c---- Index in external array.
common /laptqinc/ nn
c---- Size of current subset of data.
common /laptqinc/ ns
c---- Shape type of quadrangle.
common /laptqinc/ ntypl (64)
c---- Dummy argument.
common /laptqinc/ qu
c---- Dummy argument.
common /laptqinc/ qv
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptqinc finding if point in quadrangle.',
cbug & ' ktype=',i3)
cbug 9902 format (i3,' pu,pv= ',1p2e22.14,' (point)' /
cbug & ' au,av= ',1p2e22.14,' (vertices)' /
cbug & ' bu,bv= ',1p2e22.14 /
cbug & ' cu,cv= ',1p2e22.14 /
cbug & ' du,dv= ',1p2e22.14)
cbug 9903 format (' ntype=',i2)
cbug write ( 3, 9901) ktype
cbug do 105 n = 1, np
cbug write ( 3, 9902) n, pu(n), pv(n), au(n), av(n),
cbug & bu(n), bv(n), cu(n), cv(n), du(n), dv(n)
cbugc---- Input value of ntype.
cbug if (ktype .eq. 2) then
cbug write ( 3, 9903) ntype(n)
cbugc---- Tested for ktype = 2.
cbug endif
cbug 105 continue
cbugc***DEBUG ends.
c.... Initialize.
nerr = 0
c.... Test for input errors.
if (np .le. 0) then
nerr = 1
go to 210
endif
if ((ktype .lt. -1) .or. (ktype .gt. 2)) then
nerr = 2
go to 210
endif
c.... Set up the indices of the first subset of data.
n1 = 1
n2 = min (np, 64)
110 ns = n2 - n1 + 1
c.... Find the distances from point "p" to the sides of the quadrangle "abcd".
call aptptlc (pu(n1), pv(n1), au(n1), av(n1), bu(n1), bv(n1),
& ns, tol, -1, pab(n1), fdmin, nlim, itrunab, nerr)
call aptptlc (pu(n1), pv(n1), bu(n1), bv(n1), cu(n1), cv(n1),
& ns, tol, -1, pbc(n1), fdmin, nlim, itrunbc, nerr)
call aptptlc (pu(n1), pv(n1), cu(n1), cv(n1), du(n1), dv(n1),
& ns, tol, -1, pcd(n1), fdmin, nlim, itruncd, nerr)
call aptptlc (pu(n1), pv(n1), du(n1), dv(n1), au(n1), av(n1),
& ns, tol, -1, pda(n1), fdmin, nlim, itrunda, nerr)
c.... Find if point "p" is inside the quadrangle "abcd".
c---- Loop over subset of data.
do 120 n = 1, ns
nn = n + n1 - 1
if ((pab(nn) .ge. 0.0) .and.
& (pbc(nn) .ge. 0.0) .and.
& (pcd(nn) .ge. 0.0) .and.
& (pda(nn) .ge. 0.0) ) then
nloc(nn) = 1
else
nloc(nn) = 0
endif
if ((itrunab(n) .ne. -1) .or.
& (itrunbc(n) .ne. -1) .or.
& (itruncd(n) .ne. -1) .or.
& (itrunda(n) .ne. -1) ) then
nloc(nn) = -1
endif
dpmin(nn) = amin1 (pab(nn), pbc(nn), pcd(nn), pda(nn))
c---- End of loop over subset of data.
120 continue
c.... See if any further tests are to be done for boomerangs, bowties.
c---- Test boomerangs and bowties.
if (ktype .ne. -1) then
c---- Find ntype.
if (ktype .eq. 1) then
call aptqvac (au(n1), av(n1), bu(n1), bv(n1),
& cu(n1), cv(n1), du(n1), dv(n1), ns, tol, 1,
& arpa, arpb, arpc, arpd,
& ntype(n1), qu, qv, nerr)
c---- Tested for ktype = 1.
endif
c---- Loop over subset of data.
do 130 n = 1, ns
nn = n + n1 - 1
c---- See if boomerang or bowtie.
if (nloc(nn) .eq. 0) then
c---- Find ntypl.
if (ktype .eq. 0) then
call aptqvac (au(nn), av(nn), bu(nn), bv(nn),
& cu(nn), cv(nn), du(nn), dv(nn), 1, tol, 1,
& arpa, arpb, arpc, arpd,
& ntypl(n), qu, qv, nerr)
c---- Already know ntype.
else
ntypl(n) = ntype(nn)
c---- Tested ktype.
endif
c.... See if point "p" is inside a boomerang or a bowtie.
c++++ Boomerang at vertex "a".
if (ntypl(n) .eq. 11) then
if ((pbc(nn) .ge. 0.0) .and. (pcd(nn) .ge. 0.0) .and.
& ((pda(nn) .ge. 0.0) .or. (pab(nn) .ge. 0.0))) then
nloc(nn) = 1
dpmin(nn) = amin1 (abs (pab(nn)), pbc(nn),
& pcd(nn), abs (pda(nn)))
endif
c++++ Boomerang at vertex "b".
elseif (ntypl(n) .eq. 12) then
if ((pcd(nn) .ge. 0.0) .and. (pda(nn) .ge. 0.0) .and.
& ((pab(nn) .ge. 0.0) .or. (pbc(nn) .ge. 0.0))) then
nloc(nn) = 1
dpmin(nn) = amin1 (abs (pbc(nn)), pcd(nn),
& pda(nn), abs (pab(nn)))
endif
c++++ Boomerang at vertex "c".
elseif (ntypl(n) .eq. 13) then
if ((pda(nn) .ge. 0.0) .and. (pab(nn) .ge. 0.0) .and.
& ((pbc(nn) .ge. 0.0) .or. (pcd(nn) .ge. 0.0))) then
nloc(nn) = 1
dpmin(nn) = amin1 (abs (pcd(nn)), pda(nn),
& pab(nn), abs (pbc(nn)))
endif
c++++ Boomerang at vertex "d".
elseif (ntypl(n) .eq. 14) then
if ((pab(nn) .ge. 0.0) .and. (pbc(nn) .ge. 0.0) .and.
& ((pcd(nn) .ge. 0.0) .or. (pda(nn) .ge. 0.0))) then
nloc(nn) = 1
dpmin(nn) = amin1 (abs (pda(nn)), pab(nn),
& pbc(nn), abs (pcd(nn)))
endif
c++++ Bowtie with good edge "ab".
elseif (ntypl(n) .eq. 21) then
if ((pda(nn) .ge. 0.0) .and. (pab(nn) .ge. 0.0) .and.
& (pbc(nn) .ge. 0.0) .and. (pcd(nn) .lt. 0.0)) then
nloc(nn) = 1
dpmin(nn) = amin1 (pda(nn), pab(nn),
& pbc(nn), abs (pcd(nn)))
endif
c++++ Bowtie with good edge "bc".
elseif (ntypl(n) .eq. 22) then
if ((pab(nn) .ge. 0.0) .and. (pbc(nn) .ge. 0.0) .and.
& (pcd(nn) .ge. 0.0) .and. (pda(nn) .lt. 0.0)) then
nloc(nn) = 1
dpmin(nn) = amin1 (pab(nn), pbc(nn),
& pcd(nn), abs (pda(nn)))
endif
c++++ Bowtie with good edge "cd".
elseif (ntypl(n) .eq. 23) then
if ((pbc(nn) .ge. 0.0) .and. (pcd(nn) .ge. 0.0) .and.
& (pda(nn) .ge. 0.0) .and. (pab(nn) .lt. 0.0)) then
nloc(nn) = 1
dpmin(nn) = amin1 (pbc(nn), pcd(nn),
& pda(nn), abs (pab(nn)))
endif
c++++ Bowtie with good edge "da".
elseif (ntypl(n) .eq. 24) then
if ((pcd(nn) .ge. 0.0) .and. (pda(nn) .ge. 0.0) .and.
& (pab(nn) .ge. 0.0) .and. (pbc(nn) .lt. 0.0)) then
nloc(nn) = 1
dpmin(nn) = amin1 (pcd(nn), pda(nn),
& pab(nn), abs (pbc(nn)))
endif
c---- Tested ntype.
endif
c---- Tested nloc.
endif
c---- End of loop over subset of data.
130 continue
c---- Tested for ktype = -1.
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 9904 format (/ 'aptqinc results:')
cbug 9905 format (i3,' nloc=',i2 /
cbug & ' pab,pbc=',1p2e22.14 /
cbug & ' pcd,pda=',1p2e22.14 /
cbug & ' dpmin= ',1pe22.14)
cbug write ( 3, 9904)
cbug do 205 n = 1, np
cbug write ( 3, 9905) n, nloc(n), pab(n), pbc(n), pcd(n), pda(n),
cbug & dpmin(n)
cbugc---- Calculated ntype.
cbug if (ktype .eq. 1) then
cbug write ( 3, 9903) ntype(n)
cbugc---- Tested for kt
c****************missing lines***********ERROR*************.
cbug 205 continue
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptqinc. (+1 line.)
end
UCRL-WEB-209832