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