subroutine aptvaxc (au, av, bu, bv, np, tol, cw, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTVAXC
c
c     call aptvaxc (au, av, bu, bv, np, tol, cw, nerr)
c
c     Version:  aptvaxc  Updated    1990 November 26 10:00.
c               aptvaxc  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 vector products cw of the np 2-D vector pairs
c               a = (au, av) and b = (bu, bv).  Vectors a and b are in the uv
c               plane.  The directions u, v, and w are orthogonal.  Any values
c               of cw less than the estimated error in their calculation, based
c               on tol, will be truncated to zero.  Flag nerr indicates any
c               input error.
c
c               With no truncation,
c                 cw = au * bv - av * bu.
c
c     Input:    au, av, bu, bv, np, tol.
c
c     Output:   cw, nerr.
c
c     Glossary:
c
c     au, av    Input    The u and v components of input vector "a".  Size np.
c                          The w components are zero.  Directions u, v and w
c                          are orthogonal.
c
c     bu, bv    Input    The u and v components of input vector "b".  Size np.
c                          The w components are zero.
c
c     cw        Output   The w component of output vector "c".  Size np.
c                          Vector (cross) product of vectors "a" and "b".
c                          The u and v components are zero.
c                          Equal to the area of the parallelogram with sides
c                          "a" and "b".
c                          Positive if the angle from "a" to "b", in the uv
c                          plane, is in the range from zero to 180 degrees.
c                          Truncated to zero if less than the estimated error in
c                          their calculation.  See tol.
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 au, av, bu, bv, cw.
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 u of input vector "a".
      dimension au      (1)
c---- Component v of input vector "a".
      dimension av      (1)
c---- Component u of input vector "b".
      dimension bu      (1)
c---- Component v of input vector "b".
      dimension bv      (1)
c---- Component w of output vector "c".
      dimension cw      (1)

c.... Local variables.

c---- Index, 1 to np.
      common /laptvaxc/ n
c---- Estimated error in cw.
      common /laptvaxc/ cwerr
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptvaxc finding vector product of vectors:' /
cbug     &  (i3,' au,av=',1p2e22.14 /
cbug     &  '    bu,bv=',1p2e22.14))
cbug      write ( 3, 9901) (n, au(n), av(n), bu(n), bv(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 vector products.

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

        cw(n) = au(n) * bv(n) - av(n) * bu(n)

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

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

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

          cwerr = 2.0 * tol * (abs (au(n) * bv(n)) +
     &                         abs (av(n) * bu(n)))
          if (abs (cw(n)) .lt. cwerr) then
            cw(n) = 0.0
          endif

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

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

  210 return

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

UCRL-WEB-209832