ISAJET/code/isasrt.F

   1 #include "isajet/pilot.h"
   2       SUBROUTINE ISASRT(X,NCH,IMAP)
   3 C----------------------------------------------------------------------
   4 C-
   5 C-   Purpose and Methods : Sorts a floating point array X into ascending order.
   6 C-                         The array IMAP contains ordered list of pointers
   7 C-
   8 C-   Inputs  : X - Floating point array
   9 C-             NCH  - Number of elements in X
  10 C-   Outputs : IMAP - pointer to ordered list in X
  11 C-   Controls: None
  12 C-
  13 C-   Created   3-OCT-1988   Rajendran Raja
  14 C-   Based on the Algorithm of D.L.Shell, High speed sorting
  15 C-   procedure , Communications of the ACM, Vol 2, July 1959, PP 30-32
  16 C----------------------------------------------------------------------
  17 #if defined(CERNLIB_IMPNONE)
  18       IMPLICIT NONE
  19 #endif
  20       REAL X(*)
  21       REAL TEMP
  22       INTEGER IMAP(*),NCH,M,I,J,K,IM,IT
  23 C----------------------------------------------------------------------
  24       M=NCH
  25    10 M=M/2       !binary chop
  26       IF(M.EQ.0)GO TO 999
  27       K=NCH-M
  28       J=1
  29    20 I=J
  30    30 IM=I+M
  31       IF(X(I).LE.X(IM))GO TO 40
  32       TEMP = X(I)
  33       X(I) = X(IM)
  34       X(IM) = TEMP
  35       IT = IMAP(I)
  36       IMAP(I)=IMAP(IM)
  37       IMAP(IM)=IT
  38       I = I-M
  39       IF(I.GE.1)GO TO 30
  40    40 J=J+1
  41       IF(J.GT.K)GO TO 10
  42       GO TO 20
  43   999 RETURN
  44       END