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