subroutine aptsclc (scale, au, av, bu, bv, pu, pv, np, tol, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTSCLC
c
c call aptsclc (scale, au, av, bu, bv, pu, pv, np, tol, nerr)
c
c Version: aptsclc Updated 1990 December 3 14:20.
c aptsclc Originated 1990 January 4 15:00.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To linearly scale the np points or vectors
c p = (pu, pv) by the factor "scale", in the direction of the
c vector a = (au, av), with the point b = (bu, bv) invariant.
c All are in the uv plane. If p = (pu, pv) are unbound vectors,
c invariant point "b" must be at the origin.
c This is the spatial part of a Lorentz transformation.
c Flag nerr indicates any input error.
c
c History: 1990 March 14. Changed tol to 0.0 in call to unit vector
c subroutine. Allows small magnitudes.
c
c Input: scale, au, av, bu, bv, pu, pv, np, tol.
c
c Output: pu, pv, nerr.
c
c Calls: aptvubc
c
c Glossary:
c
c au, av Input The u and v components of the uv plane vector defining
c the direction of linear scaling.
c
c bu, bv Input The u, v coordinates of the uv plane invariant point.
c
c nerr Output Indicates an input error, if not 0.
c 1 if np is not positive.
c 2 if the magnitude of vector "a" is too small,
c relative to tol.
c
c np Input Size of arrays pu, pv.
c
c pu, pv In/Out The u and v coordinates of a point, or components
c of a vector in the uv plane. Size np.
c
c tol Input Numerical tolerance limit. Used to test and adjust
c unit vector, matrix element, and point
c components.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Coordinate or component u. Size np.
dimension pu (1)
c---- Coordinate or component v. Size np.
dimension pv (1)
c.... Local variables.
c---- Row index of linear scaling matrix.
common /laptsclc/ i
c---- Column index of linear scaling matrix.
common /laptsclc/ j
c---- Component u of unit normal vector.
common /laptsclc/ cu
c---- Component v of unit normal vector.
common /laptsclc/ cv
c---- Difference pu(n) - bu.
common /laptsclc/ du
c---- Estimated error in du.
common /laptsclc/ duerr
c---- Difference pv(n) - bv.
common /laptsclc/ dv
c---- Estimated error in dv.
common /laptsclc/ dverr
c---- Index in pu, pv arrays.
common /laptsclc/ n
c---- Estimated error in pu.
common /laptsclc/ puerr
c---- Estimated error in pv.
common /laptsclc/ pverr
c---- Linear scaling matrix operator.
common /laptsclc/ smat (2,2)
c---- Magnitude of a vector.
common /laptsclc/ vlen
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptsclc. linear scaling by factor scale=',1pe13.5 /
cbug & ' in direction au,av=' / 5x,1p2e22.14 /
cbug & ' with invariant point bu,bv=' / 5x,1p2e22.14)
cbug 9902 format (i3,' pu,pv=',1p2e22.14)
cbug write ( 3, 9901) scale, au, av, bu, bv
cbug write ( 3, 9902) (n, pu(n), pv(n), n = 1, np)
cbugc***DEBUG ends.
c.... Initialize.
nerr = 0
c.... Test for input errors.
c---- No data to scale.
if (np .le. 0) then
nerr = 1
go to 210
endif
c.... Find the unit vector in the direction of the vector "a".
call aptvubc (au, av, 1, 0., cu, cv, vlen, nerr)
c---- Vector magnitude too small.
if (vlen .le. tol) then
nerr = 2
go to 210
endif
c.... Form the components of the linear scaling matrix.
smat(1,1) = 1.0 + (scale - 1.0) * cu**2
smat(1,2) = + (scale - 1.0) * cu * cv
smat(2,1) = + (scale - 1.0) * cu * cv
smat(2,2) = 1.0 + (scale - 1.0) * cv**2
c---- Adjust components near 0 or 1.
if (tol .gt. 0.0) then
do 120 i = 1, 2
do 110 j = 1, 2
if (abs (smat(i,j)) .le. tol) then
smat(i,j) = 0.0
elseif ((abs (abs (smat(i,j)) - 1.0)) .le. tol) then
smat(i,j) = sign (1.0, smat(i,j))
endif
110 continue
120 continue
c---- Tested tol.
endif
cbugc***DEBUG begins.
cbug 9903 format (' cu,cv=',1p2e22.14)
cbug 9904 format (/ ' smat=',2(/ 1p2e22.14))
cbug write ( 3, 9903) cu, cv
cbug write ( 3, 9904) ((smat(i,j), j = 1, 2), i = 1, 2)
cbugc***DEBUG ends.
c.... Do the linear scaling operation on the np points or vectors (pu, pv).
c.... Translate the origin to point "b", operate with smat,
c.... then translate new origin to point -"b".
c---- No truncation tests.
if (tol .le. 0.0) then
c---- Loop over points or vectors.
do 130 n = 1, np
du = pu(n) - bu
dv = pv(n) - bv
pu(n) = bu + smat(1,1) * du + smat(1,2) * dv
pv(n) = bv + smat(2,1) * du + smat(2,2) * dv
c---- End of loop over points or vectors.
130 continue
c---- Truncate small results to zero.
else
c---- Loop over points or vectors.
do 140 n = 1, np
du = pu(n) - bu
dv = pv(n) - bv
duerr = tol * (abs (pu(n)) + abs (bu))
dverr = tol * (abs (pv(n)) + abs (bv))
if (abs (du) .lt. duerr) then
du = 0.0
endif
if (abs (dv) .lt. dverr) then
dv = 0.0
endif
pu(n) = bu + smat(1,1) * du + smat(1,2) * dv
pv(n) = bv + smat(2,1) * du + smat(2,2) * dv
puerr = tol * (abs (bu) + abs (smat(1,1) * du) +
& abs (smat(1,2) * dv))
pverr = tol * (abs (bv) + abs (smat(2,1) * du) +
& abs (smat(2,2) * dv))
if (abs (pu(n)) .lt. puerr) then
pu(n) = 0.0
endif
if (abs (pv(n)) .lt. pverr) then
pv(n) = 0.0
endif
c---- End of loop over points or vectors.
140 continue
c---- Tested tol.
endif
cbugc***DEBUG begins.
cbug write ( 3, 9902) (n, pu(n), pv(n), n = 1, np)
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptsclc. (+1 line.)
end
UCRL-WEB-209832