C                                                                       00010001
C***********************************************************************
C                 COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991            *
C***********************************************************************
CTITLESAHPSRT -- SMOOTH THE ARRAY WITH A ALPHA TRIM FILTER              00020001
CA    AUTHOR       S. BICKEL                                            00030001
CA    DESIGNER     B. S BOK                                             00040001
CA    LANGUAGE     FORTRAN                                              00050001
CA    SYSTEM       IBM / CRAY                                           00060001
CA    WRITTEN      AUGUST, 1990                                         00070001
C     REVISED      12-21-91 JJC - REVISED TO MEET EDP STANDARDS.
C                                                                       00080001
CA                                                                      00090001
CA    CALL SAHPSRT(N, RA, RB)                                           01560000
CA                                                                      00110001
CA         INPUT   N      = NUMBER OF ELEMENTS IN INPUT ARRAY       I4  00120001
CA         INPUT   RA     = INPUT ARRAY TO BE SORTED                R4  00130001
CA         INPUT   RB     = INDEX WORK ARRAY                        R4  00140001
CA                                                                      00200001
C**************************************************************
C                                                             *
C SUBROUTINES AND FUNCTIONS CALLED FROM THIS ROUTINE          *
C                                                             *
C NO SUBROUTINES OR FUNCTIONS CALLED FROM THIS PROGRAM UNIT   *
C                                                             *
C**************************************************************
C                                                                       00010001
      SUBROUTINE SAHPSRT(N,RA,RB)                                       01480000
C
      IMPLICIT INTEGER (A-Z)                                            01490002
C
      INTEGER RB(N),N,L,IR,RRB,I,J                                      01500000
      REAL    RA(N),RRA                                                 01510000
C                                                                       01520002
      L = N / 2 + 1
      IR = N
 100  CONTINUE
      IF (L .GT. 1) THEN
         L = L - 1
         RRA = RA(L)
         RRB = RB(L)
      ELSE
         RRA = RA(IR)
         RRB = RB(IR)
         RA(IR) = RA(1)
         RB(IR) = RB(1)
         IR = IR - 1
         IF (IR .EQ. 1) THEN
            RA(1) = RRA
            RB(1) = RRB
            RETURN
         ENDIF
      ENDIF
      I = L
      J = I + L
 120  CONTINUE
      IF (J .LE. IR) THEN
         IF (J .LT. IR) THEN
            IF (RA(J) .LT. RA(J+1)) J = J + 1
         ENDIF
         IF (RRA .LT. RA(J)) THEN
            RA(I) = RA(J)
            RB(I) = RB(J)
            I = J
            J = J + J
         ELSE
            J = IR + 1
         ENDIF
         GO TO 120
      ENDIF
      RA(I) = RRA
      RB(I) = RRB
      GO TO 100
C
      END