subroutine aptvtol (ax, ay, az, np, kadj, knorm, tolx, toly, tolz,
& vlen, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTVTOL
c
c call aptvtol (ax, ay, az, np, kadj, knorm, tolx, toly, tolz,
c & vlen, nerr)
c
c Version: aptvtol Updated 1990 November 26 10:00.
c aptvtol Originated 1989 November 15 16:40.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To adjust the values of the components of the np vectors
c a = (ax, ay, az), according to the option kadj, and the
c numerical tolerance limits tolx, toly, tolz, and to
c renormalize to a unit vector if option knorm = 1.
c Flag nerr indicates any input error.
c
c Input: ax, ay, az, np, kadj, knorm, tolx, toly, tolz.
c
c Output: ax, ay, az, vlen, nerr.
c
c Glossary:
c
c ax,ay,az Input The x, y, z components of input vector "a". Size np.
c
c ax,ay,az Output The x, y, z components of output vector "a". Size np.
c May be adjusted, according to the option kadj, and
c the numerical tolerance limits tolx, toly, tolz.
c
c kadj Input Option for adjusting the components (ax, ay, az).
c Values from 0 to 7 are allowed:
c 0 to use a limiting value equal to the tolerance
c limit times the vector magnitude.
c Add 1 to use a limiting value equal to the tolerance
c limit.
c Add 0 to use the same tolerance limit, tolx, for
c ax, ay, and az.
c Add 2 to use tolx for ax, toly for ay, and
c tolz for az.
c Add 0 to truncate the component to zero if less than
c the limiting value.
c Add 4 to increase components less than the limiting
c value, to the limiting value, with the same sign.
c
c knorm Input Option for normalizing the adjusted vector "a" to a
c unit vector. 0 = no, 1 = yes.
c
c nerr Output Indicates an input error, it not 0.
c 1 if np is not positive.
c 2 if kadj is not from 0 to 7.
c 3 if knorm is not 0 or 1.
c
c np Input Size of arrays ax, ay, az, vlen.
c
c tolx Input Numerical tolerance limit for component ax, and
c for ax, ay and az, for kadj = 0, 1, 4, and 5.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
c toly Input Numerical tolerance limit for component ay,
c for kadj = 2, 3, 6, and 7.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
c tolz Input Numerical tolerance limit for component az,
c for kadj = 2, 3, 6, and 7.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
c vlen Output Magnitude of the input vector "a", after any
c adjustment of components has been done, but before
c any remormalization (knorm = 1).
c Will be zero if all components of "a" are zero, or
c are truncated to zero. Size np.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Component x of vector "a".
dimension ax (1)
c---- Component y of vector "a".
dimension ay (1)
c---- Component z of vector "a".
dimension az (1)
c---- Magnitude of input vector "a".
dimension vlen (1)
c.... Local variables.
c---- Square of estimated error in "a".
common /laptvtol/ aerr2
c---- A limiting value.
common /laptvtol/ err
c---- A limiting value of ax.
common /laptvtol/ errx
c---- Square of a limiting value of ax.
common /laptvtol/ errx2
c---- A limiting value of ay.
common /laptvtol/ erry
c---- Square of a limiting value of ay.
common /laptvtol/ erry2
c---- A limiting value of az.
common /laptvtol/ errz
c---- Square of a limiting value of az.
common /laptvtol/ errz2
c---- A very small number.
common /laptvtol/ fuz
c---- Index, 1 to np.
common /laptvtol/ n
c---- Initial magnitude of vector "a".
common /laptvtol/ vlen1
c---- Square of magnitude of vector "a".
common /laptvtol/ vlen2
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptvtol adjusting vectors with kadj=',i2,
cbug & ' knorm=',i2 /
cbug & ' tol(x,y,z)=',1p3e22.14)
cbug 9902 format (i3,' ax,ay,az=',1p3e22.14)
cbug write ( 3, 9901) kadj, knorm, tolx, toly, tolz
cbug write ( 3, 9902) (n, ax(n), ay(n), az(n), n = 1, np)
cbugc***DEBUG ends.
c.... Initialize.
c---- A very small number.
fuz = 1.e-99
nerr = 0
c.... Test for input errors.
if (np .le. 0) then
nerr = 1
go to 210
endif
if ((kadj .lt. 0) .or. (kadj .gt. 7)) then
nerr = 2
go to 210
endif
if ((knorm .lt. 0) .or. (knorm .gt. 1)) then
nerr = 3
go to 210
endif
c.... Test for the truncation option.
c---- Relative, isotropic, truncate.
if (kadj .eq. 0) then
c---- Loop over vectors.
do 100 n = 1, np
aerr2 = tolx**2 * (ax(n)**2 + ay(n)**2 + az(n)**2)
if (ax(n)**2 .lt. aerr2) then
ax(n) = 0.0
endif
if (ay(n)**2 .lt. aerr2) then
ay(n) = 0.0
endif
if (az(n)**2 .lt. aerr2) then
az(n) = 0.0
endif
c---- End of loop over vectors.
100 continue
c---- Absolute, isotropic, truncate.
elseif (kadj .eq. 1) then
c---- Loop over vectors.
do 110 n = 1, np
if (abs (ax(n)) .lt. tolx) then
ax(n) = 0.0
endif
if (abs (ay(n)) .lt. tolx) then
ay(n) = 0.0
endif
if (abs (az(n)) .lt. tolx) then
az(n) = 0.0
endif
c---- End of loop over vectors.
110 continue
c---- Relative, non-isotr, truncate.
elseif (kadj .eq. 2) then
c---- Loop over vectors.
do 120 n = 1, np
vlen2 = ax(n)**2 + ay(n)**2 + az(n)**2
errx2 = tolx**2 * vlen2
if (ax(n)**2 .lt. errx2) then
ax(n) = 0.0
endif
erry2 = toly**2 * vlen2
if (ay(n)**2 .lt. erry2) then
ay(n) = 0.0
endif
errz2 = tolz**2 * vlen2
if (az(n)**2 .lt. errz2) then
az(n) = 0.0
endif
c---- End of loop over vectors.
120 continue
c---- Absolute, non-isotr, truncate.
elseif (kadj .eq. 3) then
c---- Loop over vectors.
do 130 n = 1, np
if (abs (ax(n)) .lt. tolx) then
ax(n) = 0.0
endif
if (abs (ay(n)) .lt. toly) then
ay(n) = 0.0
endif
if (abs (az(n)) .lt. tolz) then
az(n) = 0.0
endif
c---- End of loop over vectors.
130 continue
c---- Relative, isotropic, increase.
elseif (kadj .eq. 4) then
c---- Loop over vectors.
do 140 n = 1, np
err = tolx * sqrt (ax(n)**2 + ay(n)**2 + az(n)**2)
ax(n) = sign (amax1 (err, abs (ax(n))), ax(n))
ay(n) = sign (amax1 (err, abs (ay(n))), ay(n))
az(n) = sign (amax1 (err, abs (az(n))), az(n))
c---- End of loop over vectors.
140 continue
c---- Absolute, isotropic, increase.
elseif (kadj .eq. 5) then
c---- Loop over vectors.
do 150 n = 1, np
ax(n) = sign (amax1 (tolx, abs (ax(n))), ax(n))
ay(n) = sign (amax1 (tolx, abs (ay(n))), ay(n))
az(n) = sign (amax1 (tolx, abs (az(n))), az(n))
c---- End of loop over vectors.
150 continue
c---- Relative, non-isotr, increase.
elseif (kadj .eq. 6) then
c---- Loop over vectors.
do 160 n = 1, np
vlen1 = sqrt (ax(n)**2 + ay(n)**2 + az(n)**2)
errx = tolx * vlen1
erry = toly * vlen1
errz = tolz * vlen1
ax(n) = sign (amax1 (errx, abs (ax(n))), ax(n))
ay(n) = sign (amax1 (erry, abs (ay(n))), ay(n))
az(n) = sign (amax1 (errz, abs (az(n))), az(n))
c---- End of loop over vectors.
160 continue
c---- Absolute, non-isotr, increase.
elseif (kadj .eq. 7) then
c---- Loop over vectors.
do 170 n = 1, np
ax(n) = sign (amax1 (tolx, abs (ax(n))), ax(n))
ay(n) = sign (amax1 (toly, abs (ay(n))), ay(n))
az(n) = sign (amax1 (tolz, abs (az(n))), az(n))
c---- End of loop over vectors.
170 continue
c---- Tested kadj.
endif
c.... Find the final vector magnitudes.
c---- Loop over vectors.
do 180 n = 1, np
vlen(n) = sqrt (ax(n)**2 + ay(n)**2 + az(n)**2)
c---- End of loop over vectors.
180 continue
c.... See if final vector is to be renormalized to a unit vector.
c---- Renormalize to unit vector.
if (knorm .eq. 1) then
c---- Loop over vectors.
do 190 n = 1, np
ax(n) = ax(n) / (vlen(n) + fuz)
ay(n) = ay(n) / (vlen(n) + fuz)
az(n) = az(n) / (vlen(n) + fuz)
c---- End of loop over vectors.
190 continue
endif
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptvtol results:' /
cbug & (i3,' vlen= ',1pe22.14 /
cbug & ' ax,ay,az=',1p3e22.14))
cbug write ( 3, 9903) (n, vlen(n), ax(n), ay(n), az(n), n = 1, np)
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptvtol. (+1 line.)
end
UCRL-WEB-209832