subroutine aptrefq (refm, tol, ux, uy, uz, nerr)
ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c SUBROUTINE APTREFQ
c
c call aptrefq (refm, tol, ux, uy, uz, nerr)
c
c Version: aptrefq Updated 1990 January 10 15:20.
c aptrefq Originated 1989 November 2 14:10.
c
c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c Purpose: To find the unit vector u = (ux, uy, uz) normal to the
c reflection plane corresponding to the reflection operator refm.
c The operator refm must be a 3 x 3 matrix, with unit row and
c column vectors, unitary and symmetric, with a trace (spur) of 1.
c Components of u less than the estimated error in their
c calculation, based on tol, will be truncated to zero.
c Flag nerr indicates any error in the composition of refm.
c
c Input: refm, tol.
c
c Output: ux, uy, uz, nerr.
c
c Glossary:
c
c nerr Output Indicates an input error, if not 0.
c 1 is added if matrix trace is bad.
c 2 is added for each row or column vector that is
c not a unit vector.
c 20 is added for each off-diagonal element that is
c not symmetric.
c
c refm Output Reflection operator, dimensioned refm(3,3). Must be
c unitary, symmetric, with a trace of 1.0.
c
c tol Input Numerical tolerance limit. Used to test unit vector
c components.
c On Cray computers, recommend 1.e-5 to 1.e-11.
c
c ux,uy,uz Output The x, y, z components of the unit vector normal to
c the reflection plane.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.
c.... Dimensioned arguments.
c---- Reflection matrix.
dimension refm (3,3)
c.... Local variables.
c---- Array index.
common /laptrefq/ n
c---- Square of magnitude of row vector.
common /laptrefq/ sumrow (3)
c---- Square of magnitude of column vector.
common /laptrefq/ sumcol (3)
c---- Sum of diagonal elements.
common /laptrefq/ trace
cbugc***DEBUG begins.
cbug common /laptrefq/ i
cbug common /laptrefq/ j
cbug 9901 format (/ 'aptrefq refm=',3(/ 1p3e22.14))
cbug write ( 3, 9901) ((refm(i,j), j = 1, 3), i = 1, 3)
cbugc***DEBUG ends.
c.... Initialize.
nerr = 0
ux = -1.e+99
uy = -1.e+99
uz = -1.e+99
c.... Test the matrix trace (spur).
trace = refm(1,1) + refm(2,2) + refm(3,3)
if (abs (trace - 1.0) .gt. tol) then
cbugc***DEBUG begins.
cbug 9902 format (' bad trace=',1pe22.14)
cbug write ( 3, 9902) trace
cbugc***DEBUG ends.
nerr = 1
endif
c.... Test the row and column vectors.
do 110 n = 1, 3
sumrow(n) = refm(n,1)**2 + refm(n,2)**2 + refm(n,3)**2
if ((sumrow(n) - 1.0) .gt. tol) then
cbugc***DEBUG begins.
cbug 9903 format (' bad row=',i2,1pe22.14)
cbug write ( 3, 9903) n, sumrow
cbugc***DEBUG ends.
nerr = nerr + 2
endif
sumcol(n) = refm(1,n)**2 + refm(2,n)**2 + refm(3,n)**2
if ((sumcol(n) - 1.0) .gt. tol) then
cbugc***DEBUG begins.
cbug 9904 format (' bad col=',i2,1pe22.14)
cbug write ( 3, 9904) n, sumcol
cbugc***DEBUG ends.
nerr = nerr + 2
endif
110 continue
c.... Test the symmetry of the matrix.
if (abs (refm(1,2) - refm(2,1)) .gt. tol) then
nerr = nerr + 20
endif
if (abs (refm(1,3) - refm(3,1)) .gt. tol) then
nerr = nerr + 20
endif
if (abs (refm(2,3) - refm(3,2)) .gt. tol) then
nerr = nerr + 20
endif
if (nerr .ne. 0) then
cbugc***DEBUG begins.
cbug 9905 format (' bad matrix in aptrefq.')
cbug write ( 3, 9905)
cbugc***DEBUG ends.
go to 210
endif
c.... Find the unit vector normal to the reflection plane.
ux = sqrt (0.5 * (1.0 - refm(1,1)))
c++++ May change sign.
uy = sqrt (0.5 * (1.0 - refm(2,2)))
c++++ May change sign.
uz = sqrt (0.5 * (1.0 - refm(3,3)))
if ((ux .ge. uy) .and. (ux .ge. uz)) then
uy = -0.5 * refm(1,2) / ux
uz = -0.5 * refm(1,3) / ux
elseif ((uy .ge. uz) .and. (uy .ge. ux)) then
ux = -0.5 * refm(1,2) / uy
uz = -0.5 * refm(2,3) / uy
elseif ((uz .ge. ux) .and. (uz .ge. uy)) then
ux = -0.5 * refm(1,3) / uz
uy = -0.5 * refm(2,3) / uz
endif
cbugc***DEBUG begins.
cbug 9906 format (' ux,uy,uz=',1p3e22.14)
cbug write ( 3, 9906) ux, uy, uz
cbugc***DEBUG ends.
210 return
c.... End of subroutine aptrefq. (+1 line.)
end
UCRL-WEB-209832