subroutine aptrans (xran, np, nran, nerr)

ccbeg.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c                             SUBROUTINE APTRANS
c
c     call aptrans (xran, np, nran, nerr)
c
c     Version:  aptrans  Updated    1990 July 23 13:20.
c               aptrans  Originated 1990 July 23 13:20.
c
c     Author:   Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123.
c
c
c     Purpose:  To randomly sample, without duplication, nran values of xran
c               from the array xran(n), n = 1, np.  All values of xran are
c               initially equally probable.
c               Flag nerr indicates any input errors.
c
c     Input:    xran, np, nran.
c
c     Output:   xran, nerr.
c
c     Glossary:
c
c     nerr      Output   Indicates an input error, if not 0.
c                          1 if np is less than 1.
c                          2 if nran is less than 1, or exceeds np.
c
c     np        Input    Size of array xran.  Must be at least 1.
c
c     nran      Input    Number of xran values to be randomly sampled.
c                          Must be from 1 to np.
c
c     xran      In/Out   Array from which xran values are to be randomly sampled
c                          without duplication.  Size np.
c                          The first nran values are the desired result.
c                          Any remainder of the array (indices nran + 1 to np)
c                          will be randomized.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccend.

c.... Dimensioned arguments.

c---- Input (1 to np), output (1 to nran).
      dimension xran    (1)

c.... Local variables.

c---- Index in array xran.
      common /laptrans/ n
c---- Index in array xran.
      common /laptrans/ nn
c---- Temporary value of xran.
      common /laptrans/ xtemp
cbugc***DEBUG begins.
cbug 9901 format (/ 'aptrans randomly sampling unique values.' /
cbug     &  (i3,' ixin=',i5,' xran=',1pe22.14))
cbug      write ( 3, 9901) (n, xran(n), xran(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

      if ((nran .le. 0) .or. (nran .gt. np)) then
        nerr = 2
        go to 210
      endif

c---- Loop over table swaps.
      do 110 n = 1, nran

        nn       = n + ranf( ) * (np - n + 1)
        xtemp    = xran(n)
        xran(n)  = xran(nn)
        xran(nn) = xtemp

c---- End of loop over table swaps.
  110 continue
cbugc***DEBUG begins.
cbug 9902 format (/ 'aptrans results:' /
cbug     &  (i3,' iran=',i5,' xran=',1pe22.14))
cbug      write ( 3, 9902) (n, xran(n), xran(n), n = 1, nran)
cbugc***DEBUG ends.

  210 return

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

UCRL-WEB-209832