subroutine aptvtoc (au, av, np, kadj, knorm, tolu, tolv,
& vlen, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTVTOC
c
c call aptvtoc (au, av, np, kadj, knorm, tolu, tolv, vlen, nerr)
c
c Version: aptvtoc Updated 1990 November 26 10:00.
c aptvtoc 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 2-D vectors
c a = (au, av), according to the option kadj, and the
c numerical tolerance limits tolu and tolv, and to
c renormalize to a unit vector if option knorm = 1.
c Flag nerr indicates any input error.
c
c Input: au, av, np, kadj, knorm, tolu, tolv.
c
c Output: au, av, vlen, nerr.
c
c Glossary:
c
c au, av Input The u and v components of input vector "a". Size np.
c Directions u, v and w are orthogonal.
c
c au, av Output The u and v components of output vector "a". Size np.
c May be adjusted, according to the option kadj, and
c the numerical tolerance limits tolu and tolv.
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 kadj Input Option for adjusting the components (au, av).
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, tolu, for
c au and av.
c Add 2 to use tolu for au, tolv for av.
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 np Input Size of arrays au, av, vlen.
c
c tolu Input Numerical tolerance limit for component au, and
c for au and av, for kadj = 0, 1, 4, and 5.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
c tolv Input Numerical tolerance limit for component av,
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 u of vector "a".
dimension au (1)
c---- Component v of vector "a".
dimension av (1)
c---- Magnitude of input vector "a".
dimension vlen (1)
c.... Local variables.
c---- Square of estimated error in "a".
common /laptvtoc/ aerr2
c---- A limiting value.
common /laptvtoc/ err
c---- A limiting value of au.
common /laptvtoc/ erru
c---- Square of a limiting value of au.
common /laptvtoc/ erru2
c---- A limiting value of av.
common /laptvtoc/ errv
c---- Square of a limiting value of av.
common /laptvtoc/ errv2
c---- A very small number.
common /laptvtoc/ fuz
c---- Index, 1 to np.
common /laptvtoc/ n
c---- Initial magnitude of vector "a".
common /laptvtoc/ vlen1
c---- Square of magnitude of vector "a".
common /laptvtoc/ vlen2
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptvtoc adjusting vectors with kadj=',i2,
cbug & ' knorm=',i2 /
cbug & ' tol(u,v)=',1p2e12.5)
cbug 9902 format (i3,' au,av= ',1p2e22.14)
cbug write ( 3, 9901) kadj, knorm, tolu, tolv
cbug write ( 3, 9902) (n, au(n), av(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 = tolu**2 * (au(n)**2 + av(n)**2)
if (au(n)**2 .lt. aerr2) then
au(n) = 0.0
endif
if (av(n)**2 .lt. aerr2) then
av(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 (au(n)) .lt. tolu) then
au(n) = 0.0
endif
if (abs (av(n)) .lt. tolu) then
av(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 = au(n)**2 + av(n)**2
erru2 = tolu**2 * vlen2
if (au(n)**2 .lt. erru2) then
au(n) = 0.0
endif
errv2 = tolv**2 * vlen2
if (av(n)**2 .lt. errv2) then
av(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 (au(n)) .lt. tolu) then
au(n) = 0.0
endif
if (abs (av(n)) .lt. tolv) then
av(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 = tolu * sqrt (au(n)**2 + av(n)**2)
au(n) = sign (amax1 (err, abs (au(n))), au(n))
av(n) = sign (amax1 (err, abs (av(n))), av(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
au(n) = sign (amax1 (tolu, abs (au(n))), au(n))
av(n) = sign (amax1 (tolu, abs (av(n))), av(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 (au(n)**2 + av(n)**2)
erru = tolu * vlen1
errv = tolv * vlen1
au(n) = sign (amax1 (erru, abs (au(n))), au(n))
av(n) = sign (amax1 (errv, abs (av(n))), av(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
au(n) = sign (amax1 (tolu, abs (au(n))), au(n))
av(n) = sign (amax1 (tolv, abs (av(n))), av(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 (au(n)**2 + av(n)**2)
c---- End of loop over vectors.
180 continue
c.... See if the 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
au(n) = au(n) / (vlen(n) + fuz)
av(n) = av(n) / (vlen(n) + fuz)
c---- End of loop over vectors.
190 continue
endif
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptvtoc results:' /
cbug & (i3,' au,av,len=',1p3e22.14))
cbug write ( 3, 9903) (n, au(n), av(n), vlen(n), n = 1, np)
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptvtoc. (+1 line.)
end
UCRL-WEB-209832