subroutine aptrich (a, b, c, tol, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTRICH c c call aptrich (a, b, c, tol, nerr) c c Version: aptrich Updated 1999 September 13 13:30. c aptrich Originated 1999 September 13 13:30. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: Test to see if a real triangle, with positive area, can be c constructed with edge lengths a, b and c. Each edge length c must be greater than emin and less than emax, where c emin = tol * (abs (a) + abs (b) + abs (c)), and c emax = 0.5 * (a + b + c) * (1.0 - tol). c Flag nerr indicates any violation of these conditions. c c Input: a, b, c, tol. c c Output: nerr. c c Calls: None c c Glossary: c c a Input The length of edge a of the triangle. c Must not be too short or too long. See nerr. c c b Input The length of edge b of the triangle. c Must not be too short or too long. See nerr. c c c Input The length of edge c of the triangle. c Must not be too short or too long. See nerr. c c nerr Output Indicates an input error, if not 0. c 1 if an edge length is not greater than c emin = tol * (abs (a) + abs (b) + abs (c)). c One or more edges are too short, or negative. c 2 if an edge length is not less than c emax = 0.5 * (a + b + c) * (1.0 - tol). c One edge is too long. 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. integer nerr ! Error indicator. real tol ! Numerical tolerence limit. c.... Local variables. real emax ! Maximum allowed edge length. real emin ! Minimum allowed edge length. real per ! Perimeter of triangle, a + b + c. real pera ! Perimeter of triangle, |a| + |b| + |c|. cbugc***DEBUG begins. cbug 9901 format (/ 'aptrich testing triangle edge lengths.', 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 c.... Test for input errors. pera = abs (a) + abs (b) + abs (c) emin = tol * pera if (( a .le. emin) .or. & ( b .le. emin) .or. & ( c .le. emin)) then nerr = 1 go to 410 endif per = a + b + c emax = 0.5 * per * (1.0 - tol) if ((a .ge. emax) .or. & (b .ge. emax) .or. & (c .ge. emax)) then nerr = 2 go to 410 endif 410 continue cbugc***DEBUG begins. cbug 9916 format (/ 'aptrich results. nerr = ',i2) cbug write ( 3, 9916) nerr cbugc***DEBUG ends. return c.... End of subroutine aptrich. (+1 line.) end UCRL-WEB-209832