subroutine aptpolc (au, av, bu, bv, np, tol, cu, cv, sl, ri, rc,
& ap, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTPOLC
c
c call aptpolc (au, av, bu, bv, np, tol, cu, cv, sl, ri, rc,
c & ap, nerr)
c
c Version: aptpolc Updated 1990 December 4 17:10.
c aptpolc Originated 1989 September 19 15:50.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To find the np vertices c = (cu, cv) of the regular polygon of
c np sides in the uv plane, with the center at point a = (au, av),
c and the first vertex at point b = (bu, bv).
c Also, to find the edge length sl, the radius of the inscribed
c circle ri, the radius of the circumscribed circle rc, and the
c area of the polygon ap.
c Flag nerr indicates any input error.
c
c Note: Other subroutines may be used to translate (apttrac), rotate
c (aptrotc) or scale (aptsclu) the regular polygon generated by
c aptpolc. Subroutine aptpoly may be used to generate a regular
c polyhedron with arbitrary position, size and orientation in
c 3-D space.
c
c Input: au, av, bu, bv, np, tol.
c
c Output: cu, cv, sl, ri, rc, ap, nerr.
c
c Glossary:
c
c ap Output The area of the polygon.
c ap = 0.5 * np * ri * sl.
c ap = 0.5 * np * rc**2 * sin (2.0 * pi / np).
c
c au, av Input The u and v coordinates of the center of the polygon.
c
c bu, bv Input The u and v coordinates of the first vertex of the
c regular polygon with np sides. If point "b"
c coincides with point "a", all vertices "c" will also
c be at point "a".
c
c cu, cv Output The u and v coordinates of the vertices of the regular
c polygon in the uv plane, centered at point "a", with
c the first vertex at point "b". Size np.
c The vertices will be in counterclockwise order around
c the center.
c
c nerr Output Indicates an input error, if not 0.
c 1 if np is not three or more.
c
c np Input The number of sides or vertices on the regular polygon.
c Must be at least 3.
c
c rc Output The radius of the circumscribed circle, or distance
c from point "a" to any vertex "c", including "b".
c rc = sqrt ((bu - au)**2 + (bv - av)**2).
c rc = ri * sec (pi / np).
c
c ri Output The radius of the inscribed circle, or perpendicular
c distance from point "a" to any edge of the polygon.
c ri = rc * cos (pi / np).
c
c sl Output The length of an edge of the regular polygon.
c sl = 2.0 * rc * sin (pi / np).
c sl = 2.0 * ri * tan (pi / 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 a polygon vertex.
dimension cu (1)
c---- Coordinate v of a polygon vertex.
dimension cv (1)
c.... Local variables.
c---- Estimated error in cu.
common /laptpolc/ cuerr
c---- Estimated error in cv.
common /laptpolc/ cverr
c---- Cosine of angle pi / np.
common /laptpolc/ cosph
c---- Cosine of angle 2.0 * pi / np.
common /laptpolc/ costh
c---- Index in local array.
common /laptpolc/ n
c---- Mathematical constant, pi.
common /laptpolc/ pi
c---- Sine of angle pi / np.
common /laptpolc/ sinph
c---- Sine of angle 2.0 * pi / np.
common /laptpolc/ sinth
c---- Angle 2.0 * pi / np.
common /laptpolc/ theta
cbugc***DEBUG begins.
cbugc---- Same as bu.
cbug common /laptpolc/ pu
cbugc---- Same as bv.
cbug common /laptpolc/ pv
cbug 9901 format (/ 'aptpolc. Find the vertices of a regular polygon.',
cbug & ' np=',i5,' tol=',1pe13.5 /
cbug & ' Center at a, first vertex at b:' /
cbug & ' au,av=',1p2e22.14 /
cbug & ' bu,bv=',1p2e22.14)
cbug write ( 3, 9901) np, tol, au, av, bu, bv
cbugc***DEBUG ends.
c.... Initialize.
c---- Mathematical constant, pi.
pi = 3.14159265358979323
nerr = 0
c.... Test for input errors.
c---- No polygon.
if (np .lt. 3) then
nerr = 1
go to 210
endif
c.... Find the needed angle functions.
theta = 2.0 * pi / np
costh = cos (theta)
sinth = sin (theta)
cosph = cos (0.5 * theta)
sinph = sin (0.5 * theta)
cbugc***DEBUG begins.
cbug 9902 format (/ ' costh=',1pe22.14,' sinth=',1pe22.14)
cbug write ( 3, 9902) costh, sinth
cbugc***DEBUG ends.
c.... Temporarily move the origin to point "a".
cu(1) = bu - au
cv(1) = bv - av
c.... See if the results should be tested for truncation error.
c---- Truncate small results to zero.
if (tol .gt. 0.0) then
if (abs (costh) .lt. tol) then
costh = 0.0
endif
cuerr = tol * (abs (bu) + abs (au))
cverr = tol * (abs (bv) + abs (av))
if (abs (cu(1)) .lt. cuerr) then
cu(1) = 0.0
endif
if (abs (cv(1)) .lt. cverr) then
cv(1) = 0.0
endif
c---- Tested tol.
endif
c.... Find the circumscribed and inscribed circle radii, the edge length,
c.... and the polygon area.
rc = sqrt (cu(1)**2 + cv(1)**2)
ri = rc * cosph
sl = 2.0 * rc * sinph
ap = 0.5 * np * ri * sl
c.... Generate the remaining vertices of the polygon.
c.... See if the results should be tested for truncation error.
c---- No truncation.
if (tol .le. 0.0) then
c---- Loop over vertices.
do 110 n = 2, np
cu(n) = cu(n-1) * costh - cv(n-1) * sinth
cv(n) = cu(n-1) * sinth + cv(n-1) * costh
c---- End of loop over vertices.
110 continue
c---- Truncate small values to zero.
else
c---- Loop over vertices.
do 120 n = 2, np
cu(n) = cu(n-1) * costh - cv(n-1) * sinth
cv(n) = cu(n-1) * sinth + cv(n-1) * costh
cuerr = tol * (abs (cu(n-1)) * costh + abs (cv(n-1)) * sinth)
cverr = tol * (abs (cu(n-1)) * sinth + abs (cv(n-1)) * costh)
if (abs (cu(n)) .lt. cuerr) then
cu(n) = 0.0
endif
if (abs (cv(n)) .lt. cverr) then
cv(n) = 0.0
endif
c---- End of loop over vertices.
120 continue
c---- Tested tol.
endif
cbugc***DEBUG begins.
cbug pu = cu(np) * costh - cv(np) * sinth
cbug pv = cu(np) * sinth + cv(np) * costh
cbug cuerr = tol * (abs (cu(np)) * costh + abs (cv(np)) * sinth)
cbug cverr = tol * (abs (cu(np)) * sinth + abs (cv(np)) * costh)
cbug if (abs (pu) .lt. cuerr) then
cbug pu = 0.0
cbug endif
cbug if (abs (pv) .lt. cverr) then
cbug pv = 0.0
cbug endif
cbugc***DEBUG ends.
c.... Restore the origin, to center the polygon on point "a".
cu(1) = bu
cv(1) = bv
c.... See if the results should be tested for truncation error.
c---- No truncation.
if (tol .le. 0.0) then
c---- Loop over vertices.
do 130 n = 2, np
cu(n) = cu(n) + au
cv(n) = cv(n) + av
c---- End of loop over vertices.
130 continue
c---- Truncate small values to zero.
else
c---- Loop over vertices.
do 140 n = 2, np
cuerr = tol * (abs (cu(n)) + abs (au))
cverr = tol * (abs (cv(n)) + abs (av))
cu(n) = cu(n) + au
cv(n) = cv(n) + av
if (abs (cu(n)) .lt. cuerr) then
cu(n) = 0.0
endif
if (abs (cv(n)) .lt. cverr) then
cv(n) = 0.0
endif
c---- End of loop over vertices.
140 continue
c---- Tested tol.
endif
cbugc***DEBUG begins.
cbug cuerr = tol * (abs (pu) + abs (au))
cbug cverr = tol * (abs (pv) + abs (av))
cbug pu = pu + au
cbug pv = pv + av
cbug if (abs (pu) .lt. cuerr) then
cbug pu = 0.0
cbug endif
cbug if (abs (pv) .lt. cverr) then
cbug pv = 0.0
cbug endif
cbug 9903 format (/ 'aptpolc results:' /
cbug & ' ri,rc=',1p2e22.14 /
cbug & ' sl,ap=',1p2e22.14 /
cbug & (i3,' cu,cv=',1p2e22.14))
cbug 9904 format (/ ' closure:' /
cbug & ' bu,bv=',1p2e22.14 /
cbug & ' pu,pv=',1p2e22.14)
cbug write ( 3, 9903) ri, rc, sl, ap,
cbug & (n, cu(n), cv(n), n = 1, np)
cbug write ( 3, 9904) bu, bv, pu, pv
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptpolc. (+1 line.)
end
UCRL-WEB-209832