subroutine aptvdos (ax, ay, az, bx, by, bz, np, tol, spab, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTVDOS
c
c     call aptvdos (ax, ay, az, bx, by, bz, np, tol, spab, nerr)
c
c     Version:  aptvdos  Updated    1990 November 26 10:00.
c               aptvdos  Originated 1989 September 21 10:40.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To find the scalar (dot) products spab of the vector
c               a = (ax, ay, az) and the np vectors b = (bx, by, bz).
c               The value of spab will be truncated to zero, if less than
c               the estimated error in its calculation, based on tol.
c               Flag nerr indicates any input error.
c
c               With no truncation, spab = ax * bx + ay * by + az * bz.
c
c     Input:    ax, ay, az, bx, by, bz, np, tol.
c
c     Output:   spab, nerr.
c
c     Glossary:
c
c     ax,ay,az  Input    The x, y, z components of a vector.
c
c     bx,by,bz  Input    The x, y, z components of a vector.  Size np.
c
c     nerr      Output   Indicates an input error, if not 0.
c                          1 if np is not positive.
c
c     np        Input    Size of arrays bx, by, bz, spab.
c
c     spab      Output   Scalar product of vectors "a" and "b".  Will be
c                          truncated to zero, if less than the estimated error
c                          in its calculation, based on tol.  Size np.
c
c     tol       Input    Numerical tolerance limit.
c                          On Cray computers, recommend 1.e-5 to 1.e-11.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Dimensioned arguments.

c---- Component x of input vector "b".
      dimension bx      (1)
c---- Component y of input vector "b".
      dimension by      (1)
c---- Component z of input vector "b".
      dimension bz      (1)
c---- Input vector magnitude.
      dimension spab    (1)

c.... Local variables.

c---- Index, 1 to np.
      common /laptvdos/ n
c---- Estimated error in spab.
      common /laptvdos/ sperr
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptvdos finding scalar products.',
cbug     &  '  np=',i3,', tol=',1pe13.5 /
cbug     &  '     ax,ay,az=',1p3e22.14)
cbug 9902 format (i3,'  bx,by,bz=',1p3e22.14)
cbug      write ( 3, 9901) np, tol, ax, ay, az
cbug      write ( 3, 9902) (n, bx(n), by(n), bz(n), n = 1, np)
cbugc***DEBUG ends.

c.... Initialize.

      nerr = 0

c.... Test for input errors.

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

c.... Find the scalar products.

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

        spab(n) = ax * bx(n) + ay * by(n) + az * bz(n)

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

c---- Truncate small values to zero.
      if (tol .gt. 0.0) then

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

          sperr   = 2.0 * tol * (abs (ax * bx(n)) +
     &              abs (ay * by(n)) + abs (az * bz(n)))
          if (abs (spab(n)) .lt. sperr) then
            spab(n) = 0.0
          endif

c---- End of loop over scalar products.
  120   continue

c---- Tested tol.
      endif
cbugc***DEBUG begins.
cbug 9903 format (/ 'aptvdos results:' /
cbug     &  (i3,'  spab=    ',1pe22.14))
cbug      write ( 3, 9903) (n, spab(n), n = 1, np)
cbugc***DEBUG ends.

  210 return

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

UCRL-WEB-209832