subroutine aptcyis (rcyl, np, tol, qc, qu, qv, qw, & quv, qvw, qwu, quu, qvv, qww, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTCYIS c c call aptcyis (rcyl, np, tol, qc, qu, qv, qw, c & quv, qvw, qwu, quu, qvv, qww, nerr) c c Version: aptcyis Updated 1990 December 12 14:30. c aptcyis Originated 1990 December 12 10:30. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: For each of np sets of input data, to find the equation of the c right circular cylinder on the w axis, with a radius of rcyl. c The coordinates (u,v,w) are along the three major orthogonal c axes, and may represent (x,y,z), (y,z,x) or (z,x,y). c c The equation for the cylinder is as follows: c c f(u,v,w) = qc + qu * u + qv * v + qw * w + c quv * u * v + qvw * v * w + qwu * w * u + c quu * u**2 + qvv * v**2 + qww * w**2 = 0 c c where qu = qv = qw = quv = qvw = qwu = qvv = 0, c qc = -rcyl**2, and quu = qvv = 1.0. c c General case: c c If rcyl is not zero, the surface will be a right circular c cylinder on the w axis of radius rcyl. c c Singular case: c c If rcyl is zero, the surface will be a line on the w axis. c c Note: Use apttris and aptrois to translate and rotate the cylinder c into any desired position and orientation. c Use aptcnis or aptcois to find the equation of a cone c symmetric around a major axis. c Use aptelis to find the equation of an ellipsoid symmetric c around a major axis. c c Input: rcyl, np, tol. c c Output: qc, qu, qv, qw, quv, qvw, qwu, quu, qvv, qww, nerr. c c Glossary: c c nerr Output Indicates an input error, if not zero: c 1 if np is not positive. c c np Input Size of arrays rcyl, qc, qu, qv, qw, quv, qvw, qwu, c quu, qvv, qww. c c qc Output Constant term in the equation of the cylinder. c Size np. qc = -rcyl**2. c c qu,qv,qw Output Coefficients of u, v, w in the equation of the c cylinder. Size np. qu = qv = qw = 0. c c q.. Output Coefficients of second-order terms in the equation of c the cylinder: quv, qvw, qwu, quu, qvv, qww. c Coefficients of u*v, v*w, w*u, u**2, v**2, w**2, c respectively. Size np. c quv = qvw = qwu = qww = 0. quu = qvv = 1. c c rcyl Input Radius of the cylinder. Size np. c Treated as zero if rcyl**2 less than tol. 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---- Coefficient of term 1.0. dimension qc (1) c---- Coefficient of term u. dimension qu (1) c---- Coefficient of term u**2. dimension quu (1) c---- Coefficient of term u * v. dimension quv (1) c---- Coefficient of term v. dimension qv (1) c---- Coefficient of term v**2. dimension qvv (1) c---- Coefficient of term v * w. dimension qvw (1) c---- Coefficient of term w. dimension qw (1) c---- Coefficient of term w * u. dimension qwu (1) c---- Coefficient of term w**2. dimension qww (1) c---- Radius of the cylinder. dimension rcyl (1) c.... Local variables. c---- Index in external array. common /laptcyis/ n cbugc***DEBUG begins. cbug 9901 format (/ 'aptcyis finding the equation of a cylinder.', cbug & ' tol=',1pe13.5) cbug 9902 format ( cbug & i3,' rcyl=',1pe22.14) cbug write ( 3, 9901) tol cbug write ( 3, 9902) (n, rcyl(n), n = 1, np) cbugc***DEBUG ends. c.... Initialize. nerr = 0 c.... Test for input errors. if (np .le. 0) then nerr = 1 cbugc***DEBUG begins. cbug 9903 format (/ "aptcyis fatal. Non-positive np =",i5) cbug write ( 3, 9903) np cbugc***DEBUG ends. go to 210 endif c.... Find the coefficients of the equation of the cylinder. c---- Loop over data. do 120 n = 1, np qc(n) = -rcyl(n)**2 qu(n) = 0.0 qv(n) = 0.0 qw(n) = 0.0 quv(n) = 0.0 qvw(n) = 0.0 qwu(n) = 0.0 quu(n) = 1.0 qvv(n) = 1.0 qww(n) = 0.0 c---- End of loop over data. 120 continue c.... See if the results should be tested for truncation error. c---- Test for truncation to zero. if (tol .gt. 0.0) then c---- Loop over data. do 130 n = 1, np if (abs (qc(n)) .lt. tol) then qc(n) = 0.0 endif c---- End of loop over data. 130 continue c---- Tested tol. endif cbugc***DEBUG begins. cbug 9904 format (/ 'aptcyis results:' / cbug & (i3,' qc= ',1pe22.14 / cbug & ' qu,qv,qw= ',1p3e22.14 / cbug & ' quv,qvw,qwu=',1p3e22.14 / cbug & ' quu,qvv,qww=',1p3e22.14)) cbug write ( 3, 9904) (n, qc(n), qu(n), qv(n), qw(n), cbug & quv(n), qvw(n), qwu(n), quu(n), qvv(n), qww(n), cbug & n = 1, np) cbugc***DEBUG ends. 210 return c.... End of subroutine aptcyis. (+1 line.) end UCRL-WEB-209832