subroutine apttran (ax, ay, az, px, py, pz, np, tol, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTTRAN
c
c     call apttran (ax, ay, az, px, py, pz, np, tol, nerr)
c
c     Version:  apttran  Updated    1990 December 3 16:20.
c               apttran  Originated 1989 November 2 14:10.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To translate the origin to the point a = (ax, ay, az),
c               by subtracting the vector "a" from the np points
c               p = (px, py, pz).  New coordinates less than the estimated error
c               in their calculation, based on tol, will be truncated to zero.
c               Flag nerr indicates any input error.
c
c     Input:    ax, ay, az, px, py, pz, np, tol.
c
c     Output:   px, py, pz, nerr.
c
c     Glossary:
c
c     ax,ay,az  Input    The x, y z components of vector "a", to be
c                          subtracted from points "p".
c
c     nerr      Output   Indicates an input error, if not 0.
c                          1 if np is not positive.
c
c     np        Input    Number of points (px, py, pz).
c
c     tol       Input    Numerical tolerance limit.
c                          On Cray computers, recommend 1.e-5 to 1.e-11.
c
c     px,py,pz  In/Out   The x, y, z coordinates of point "p".  Size np.
c                          Truncated to zero if smaller than the estimated
c                          error in their calculation, based on tol.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Dimensioned arguments.

c---- Coordinate x of a point.
      dimension px      (1)
c---- Coordinate y of a point.
      dimension py      (1)
c---- Coordinate z of a point.
      dimension pz      (1)

c.... Local variables.

c---- Index in px, py, pz.
      common /lapttran/ n
c---- Estimated truncation error in px.
      common /lapttran/ pxerr
c---- Estimated truncation error in py.
      common /lapttran/ pyerr
c---- Estimated truncation error in pz.
      common /lapttran/ pzerr
c---- Square of length of (ax, ay, az).
      common /lapttran/ vlen2
cbugc***DEBUG begins.
cbug 9901 format (/ 'apttran finding translated points.  New origin at:' /
cbug     &  '  ax,ay,az=',1p3e22.14)
cbug 9902 format (/ '  initial values:' /
cbug     &  (i3,' px,py,pz=',1p3e22.14))
cbug      write ( 3, 9901) ax, ay, az
cbug      write ( 3, 9902) (n, px(n), py(n), pz(n), n = 1, np)
cbugc***DEBUG ends.

c.... Initialize.

      nerr = 0

c.... Test for input errors.

      if (np .le. 0) then
        nerr = 1
cbugc***DEBUG begins.
cbug        write ( 3, '(/ "apttran fatal.  bad np=",i3)') np
cbugc***DEBUG ends.
        go to 210
      endif

      vlen2 = ax**2 + ay**2 + az**2

c---- Translate points "p".
      if (vlen2 .gt. tol**2) then

c---- No truncation.
        if (tol .le. 0.0) then

c---- Loop over points.
          do 110 n = 1, np

            px(n) = px(n) - ax
            py(n) = py(n) - ay
            pz(n) = pz(n) - az

c---- End of loop over points.
  110     continue

c---- Truncate small components to zero.
        else

c---- Loop over points.
          do 120 n = 1, np

            pxerr = tol * (abs (px(n)) + abs (ax))
            pyerr = tol * (abs (py(n)) + abs (ay))
            pzerr = tol * (abs (pz(n)) + abs (az))

            px(n) = px(n) - ax
            py(n) = py(n) - ay
            pz(n) = pz(n) - az

            if (abs (px(n)) .lt. pxerr) then
              px(n) = 0.0
            endif

            if (abs (py(n)) .lt. pyerr) then
              py(n) = 0.0
            endif

            if (abs (pz(n)) .lt. pzerr) then
              pz(n) = 0.0
            endif

c---- End of loop over points.
  120     continue

c---- Tested tol.
        endif

c---- Tested length of vector "a".
      endif

cbugc***DEBUG begins.
cbug 9903 format (/ 'apttran results:' /
cbug     &  (i3,' px,py,pz=',1p3e22.14))
cbug      write ( 3, 9903) (n, px(n), py(n), pz(n), n = 1, np)
cbugc***DEBUG ends.

  210 return

c.... End of subroutine apttran.      (+1 line.)
      end

UCRL-WEB-209832