subroutine apttrac (au, av, pu, pv, np, tol, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTTRAC
c
c     call apttrac (au, av, pu, pv, np, tol, nerr)
c
c     Version:  apttrac  Updated    1990 December 3 16:20.
c               apttrac  Originated 1990 January 4 12:00.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To translate the origin to the 2-D point a = (au, av),
c               by subtracting the vector "a" from the np 2-D points
c               p = (pu, pv).  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:    au, av, pu, pv, np, tol.
c
c     Output:   pu, pv, nerr.
c
c     Glossary:
c
c     nerr      Output   Indicates an input error, if not 0.
c                          1 if np is not positive.
c                          2 if the magnitude of (au, av) is no greater than
c                            tol.
c
c     np        Input    Number of 2-D points (pu, pv).
c
c     tol       Input    Numerical tolerance limit.
c                          On Cray computers, recommend 1.e-5 to 1.e-11.
c
c     pu, pv    In/Out   The u and v coordinates of 2-D point "p".
c                          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 u of a point.
      dimension pu      (1)
c---- Coordinate v of a point.
      dimension pv      (1)

c.... Local variables.

c---- Index in pu, pv.
      common /lapttrac/ n
c---- Estimated truncation error in pu.
      common /lapttrac/ puerr
c---- Estimated truncation error in pv.
      common /lapttrac/ pverr
c---- Square of length of (au, av).
      common /lapttrac/ vlen2
cbugc***DEBUG begins.
cbug 9901 format (/ 'apttrac translating points.  New origin at:' /
cbug     &  '  au,av=',1p2e22.14)
cbug      write ( 3, 9901) au, av
cbugc***DEBUG ends.

c.... Initialize.

      nerr = 0

c.... Test for input errors.

      if (np .le. 0) then
        nerr = 1
        go to 210
      endif

      vlen2 = au**2 + av**2
      if (vlen2 .le. tol**2) then
        nerr = 2
        go to 210
      endif
cbugc***DEBUG begins.
cbug 9902 format (/ '  initial values.' /
cbug     &  '    n   pu',20x,'pv',20x / (i5,1p2e22.14))
cbug      write ( 3, 9902) (n, pu(n), pv(n), n = 1, np)
cbugc***DEBUG ends.

c.... Translate points.

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

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

          pu(n) = pu(n) - au
          pv(n) = pv(n) - av

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

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

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

          puerr = tol * (abs (pu(n)) + abs (au))
          pverr = tol * (abs (pv(n)) + abs (av))

          pu(n) = pu(n) - au
          pv(n) = pv(n) - av

          if (abs (pu(n)) .lt. puerr) then
            pu(n) = 0.0
          endif
          if (abs (pv(n)) .lt. pverr) then
            pv(n) = 0.0
          endif

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

c---- Tested tol.
      endif

cbugc***DEBUG begins.
cbug 9903 format (/ '  final values.' /
cbug     &  '    n   pu',20x,'pv',20x / (i5,1p2e22.14))
cbug      write ( 3, 9903) (n, pu(n), pv(n), n = 1, np)
cbugc***DEBUG ends.

  210 return

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

UCRL-WEB-209832