pxsorv.f

Go to the documentation of this file.

CDECK  ID>, PXSORV.
      SUBROUTINE pxsorv (ISZ,ARY,KIX,COPT)
*.*********************************************************
*. ------
*. PXSORV
*. ------
*. SOURCE: HERWIG (B.Webber,G.Marchesini)
*. Sort a real array into assending order based on
*. the magnitude of its elements; provide an
*. integer "index array" which specifies the ordering
*. of the array.
*. Usage     :
*.
*.      PARAMETER  (NDIM=1.or.more)
*.      REAL  ARY (NDIM)
*.      INTEGER  KIX (NDIM)
*.      INTEGER  ISIZ
*.      CHARACTER*1  COPT
*.
*.      ISIZ = 1.to.NDIM
*.      COPT = 'I'
*.      CALL PXSORV (ISIZ,ARY,KIX,COPT)
*.
*. INPUT     : ISIZ  The dimension of the input array
*. INPUT     : ARY   The input array
*. OUTPUT    : KIX   The index array
*. CONTROL   : COPT  Control of output vector ARY
*.              = ' ' : return sorted ARY and index array KIX
*.              = 'I' : return index array KIX only, don't
*.                      modify ARY
*.
*.*********************************************************
      IMPLICIT NONE
      INTEGER  mxsz
      parameter(mxsz=500)
      INTEGER  isz,ix,jx
      INTEGER  kix (*),il (mxsz),ir (mxsz)
      REAL  ary (*),bry (mxsz)
      CHARACTER*1  copt
      IF (isz.GT.mxsz) THEN
          WRITE (6,fmt='('' PXSORT: Error,'',
     +           '' Max array size ='',I6)') mxsz
          kix(1) = -1
          go to 990
      END IF
      il(1) = 0
      ir(1) = 0
      DO 10 ix = 2,isz
          il(ix) = 0
          ir(ix) = 0
          jx = 1
   2      IF (ary(ix).GT.ary(jx)) go to 5
   3      IF (il(jx).EQ.0) go to 4
          jx = il(jx)
          go to 2
   4      ir(ix) = -jx
          il(jx) =  ix
          go to 10
   5      IF (ir(jx).LE.0) go to 6
          jx = ir(jx)
          go to 2
   6      ir(ix) = ir(jx)
          ir(jx) = ix
  10  CONTINUE
      ix = 1
      jx = 1
      go to 8
  20  jx = il(jx)
   8  IF (il(jx).GT.0) go to 20
   9  kix(ix) = jx
      bry(ix) = ary(jx)
      ix = ix + 1
      IF (ir(jx)) 12,30,13
  13  jx = ir(jx)
      go to 8
  12  jx = -ir(jx)
      go to 9
  30  IF (copt.EQ.'I') RETURN
      DO 31 ix = 1,isz
  31  ary(ix) = bry(ix)
 990  RETURN
      END