subroutine aptrcab (a, b, c, tol, ncut, fa, aa, fb, bb, cc, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTRCAB
c
c call aptrcab (a, b, c, tol, ncut, fa, aa, fb, bb, cc, nerr)
c
c Version: aptrcab Updated 1999 September 13 14:00.
c aptrcab Originated 1999 August 26 16:50.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: For the triangle with edges a, b and c, to find the ncut
c (0 to 2) straight line(s) from edge a to edge b that cut the
c triangle into sections with equal perimeters and equal areas,
c to find the fractional distances fa and fb of the endpoints
c along the edges, and the lengths aa, bb and cc of the edges of
c the small triangle.
c Flag nerr indicates any input error.
c
c Input: a, b, c, tol.
c
c Output: ncut, fa, aa, fb, bb, cc, nerr.
c
c Calls: aptrich, aptqrts
c
c
c Glossary:
c
c a Input The length of edge a of the triangle.
c
c b Input The length of edge b of the triangle.
c
c c Input The length of edge c of the triangle.
c
c aa Output The distance of the first endpoint along edge a.
c Size 2.
c
c bb Output The distance of the second endpoint along edge b.
c Size 2.
c
c fa Output The fractional distance of the first endpoint along
c edge a. Size 2.
c fb Output The fractional distance of the second endpoint along
c edge b. Size 2.
c
c ncut Output The number of cutting lines (0, 1 or 2).
c
c nerr Output Indicates an input error, if not 0.
c 1 if an edge length is negative.
c 2 if the triangle is impossible (an edge length is
c not less than the sum of the other two edge lengths.
c
c tol Input Numerical tolerance limit.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
implicit none
c.... Arguments.
real a ! Length of edge a of the triangle.
real b ! Length of edge b of the triangle.
real c ! Length of edge c of the triangle.
real aa(2) ! Distance of point E along edge.
real bb(2) ! Distance of point F along edge.
real cc(2) ! Length of cutting line.
real fa(2) ! Fractional distance of E along edge.
real fb(2) ! Fractional distance of F along edge.
integer ncut ! Number of equipartition cutting lines.
integer nerr ! Error indicator.
real tol ! Numerical tolerence limit.
c.... Local variables.
real c2 ! Coefficient of t**2 in quadratic eq.
real c1 ! Coefficient of t in quadratic eq.
real c0 ! Coefficient of 1 in quadratic eq.
real fab ! Fractional distance from A to B.
real fac ! Fractional distance from A to C.
real fba ! Fractional distance from B to A.
real fbc ! Fractional distance from B to C.
real fca ! Fractional distance from C to A.
real fcb ! Fractional distance from C to B.
integer itrun ! Truncation flag from aptqrts.
integer n ! Index of cut line.
integer nerra ! Error flag from apt subroutine.
integer nroots ! # of real roots of quadratic equation.
real per ! Perimeter of triangle, a + b + c.
real qq ! c1**2 - 4*c2*c1.
real root1 ! First real root of quadatic equation.
real root2 ! Second real root of quadratic equation.
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptrcab finding triangle partition cuts.',
cbug & ' tol=',1pe22.14 /
cbug & ' a ,b ,c = ',1p3e22.14 )
cbug write ( 3, 9901) tol, a, b, c
cbugc***DEBUG ends.
c.... Initialize.
nerr = 0
ncut = 0
do 110 n = 1, 2
fa(n) = -1.e99
fb(n) = -1.e99
aa(n) = -1.e99
bb(n) = -1.e99
cc(n) = -1.e99
110 continue
c=======================================================================********
c.... Test for input errors.
call aptrich (a, b, c, tol, nerr)
if (nerr .ne. 0) go to 410
per = a + b + c ! Perimeter.
c.... Find any cuts from edge a to edge b.
c2 = 2.0 * a
c1 = -per
c0 = b
call aptqrts (0, c2, c1, c0, qq, tol,
& nroots, root1, root2, itrun)
if (nroots .ge. 1) then
if ((root1 .ge. (0.5 - tol)) .and.
& (root1 .le. (1.0 + tol))) then
fcb = root1
fca = 0.5 / fcb
fbc = 1.0 - fcb
if (abs (fbc) .le. tol) then
fbc = 0.0
fcb = 1.0
fac = 0.5
fca = 0.5
endif
fac = 1.0 - fca
if (abs (fac) .le. tol) then
fac = 0.0
fca = 1.0
fbc = 0.5
fcb = 0.5
endif
ncut = ncut + 1
fa(ncut) = fcb
fb(ncut) = fca
aa(ncut) = fcb * a
bb(ncut) = fca * b
cc(ncut) = sqrt (per * (c - 0.25 * per))
endif ! Cut endpoints are on edges.
endif ! Cut endpoints are real.
350 if (nroots .eq. 2) then
if ((root2 .ge. (0.5 - tol)) .and.
& (root2 .le. (1.0 + tol))) then
fcb = root2
fca = 0.5 / fcb
fbc = 1.0 - fcb
if (abs (fbc) .le. tol) then
fbc = 0.0
fcb = 1.0
fca = 0.5
fac = 0.5
endif
fac = 1.0 - fca
if (abs (fac) .le. tol) then
fac = 0.0
fca = 1.0
fbc = 0.5
fcb = 0.5
endif
ncut = ncut + 1
fa(ncut) = fcb
fb(ncut) = fca
aa(ncut) = fcb * a
bb(ncut) = fca * b
cc(ncut) = sqrt (per * (c - 0.25 * per))
endif ! Cut endpoints are on edges.
endif ! Cut endpoints are real.
c=======================================================================********
410 continue
cbugc***DEBUG begins.
cbug 9916 format (/ 'aptrcab results. nerr = ',i2,' ncut = ',i1 )
cbug 9918 format ('ncut =',i2 /
cbug & 'fa, fb = ',1p2e22.12 /
cbug & 'aa, bb, cc = ',1p3e22.12 )
cbug write ( 3, 9916) nerr, ncut
cbug
cbug if (ncut .gt. 0) then
cbug do 420 n = 1, ncut
cbug write ( 3, 9918) n, fa(n), fb(n), aa(n), bb(n), cc(n)
cbug 420 continue
cbug endif
cbugc***DEBUG ends.
return
c.... End of subroutine aptrcab. (+1 line.)
end
UCRL-WEB-209832