MICROCERN/sortzv.F

   1 *
   2 * $Id$
   3 *
   4 #include "kerngen/pilot.h"
   5       SUBROUTINE SORTZV (A,INDEX,N1,MODE,NWAY,NSORT)
   6 C
   7 C CERN PROGLIB# M101    SORTZV          .VERSION KERNFOR  3.15  820113
   8 C ORIG. 02/10/75
   9 C
  10       DIMENSION A(N1),INDEX(N1)
  11 C
  12 C
  13       N = N1
  14       IF (N.LE.0)            RETURN
  15       IF (NSORT.NE.0) GO TO 2
  16       DO 1 I=1,N
  17     1 INDEX(I)=I
  18 C
  19     2 IF (N.EQ.1)            RETURN
  20       IF (MODE)    10,20,30
  21    10 CALL SORTTI (A,INDEX,N)
  22       GO TO 40
  23 C
  24    20 CALL SORTTC(A,INDEX,N)
  25       GO TO 40
  26 C
  27    30 CALL SORTTF (A,INDEX,N)
  28 C
  29    40 IF (NWAY.EQ.0) GO TO 50
  30       N2 = N/2
  31       DO 41 I=1,N2
  32       ISWAP = INDEX(I)
  33       K = N+1-I
  34       INDEX(I) = INDEX(K)
  35    41 INDEX(K) = ISWAP
  36    50 RETURN
  37       END
  38 *     ========================================
  39       SUBROUTINE SORTTF (A,INDEX,N1)
  40 C
  41       DIMENSION A(N1),INDEX(N1)
  42 C
  43       N = N1
  44       DO 3 I1=2,N
  45       I3 = I1
  46       I33 = INDEX(I3)
  47       AI = A(I33)
  48     1 I2 = I3/2
  49       IF (I2) 3,3,2
  50     2 I22 = INDEX(I2)
  51       IF (AI.LE.A (I22)) GO TO 3
  52       INDEX (I3) = I22
  53       I3 = I2
  54       GO TO 1
  55     3 INDEX (I3) = I33
  56     4 I3 = INDEX (N)
  57       INDEX (N) = INDEX (1)
  58       AI = A(I3)
  59       N = N-1
  60       IF (N-1) 12,12,5
  61     5 I1 = 1
  62     6 I2 = I1 + I1
  63       IF (I2.LE.N) I22= INDEX(I2)
  64       IF (I2-N) 7,9,11
  65     7 I222 = INDEX (I2+1)
  66       IF (A(I22)-A(I222)) 8,9,9
  67     8 I2 = I2+1
  68       I22 = I222
  69     9 IF (AI-A(I22)) 10,11,11
  70    10 INDEX(I1) = I22
  71       I1 = I2
  72       GO TO 6
  73    11 INDEX (I1) = I3
  74       GO TO 4
  75    12 INDEX (1) = I3
  76       RETURN
  77       END
  78 *     ========================================
  79       SUBROUTINE SORTTI (A,INDEX,N1)
  80 C
  81       INTEGER A,AI
  82       DIMENSION A(N1),INDEX(N1)
  83 C
  84       N = N1
  85       DO 3 I1=2,N
  86       I3 = I1
  87       I33 = INDEX(I3)
  88       AI = A(I33)
  89     1 I2 = I3/2
  90       IF (I2) 3,3,2
  91     2 I22 = INDEX(I2)
  92       IF (AI.LE.A (I22)) GO TO 3
  93       INDEX (I3) = I22
  94       I3 = I2
  95       GO TO 1
  96     3 INDEX (I3) = I33
  97     4 I3 = INDEX (N)
  98       INDEX (N) = INDEX (1)
  99       AI = A(I3)
 100       N = N-1
 101       IF (N-1) 12,12,5
 102     5 I1 = 1
 103     6 I2 = I1 + I1
 104       IF (I2.LE.N) I22= INDEX(I2)
 105       IF (I2-N) 7,9,11
 106     7 I222 = INDEX (I2+1)
 107       IF (A(I22)-A(I222)) 8,9,9
 108     8 I2 = I2+1
 109       I22 = I222
 110     9 IF (AI-A(I22)) 10,11,11
 111    10 INDEX(I1) = I22
 112       I1 = I2
 113       GO TO 6
 114    11 INDEX (I1) = I3
 115       GO TO 4
 116    12 INDEX (1) = I3
 117       RETURN
 118       END
 119 *     ========================================
 120       SUBROUTINE SORTTC (A,INDEX,N1)
 121 C
 122       INTEGER A,AI
 123       DIMENSION A(N1),INDEX(N1)
 124 C
 125       N = N1
 126       DO 3 I1=2,N
 127       I3 = I1
 128       I33 = INDEX(I3)
 129       AI = A(I33)
 130     1 I2 = I3/2
 131       IF (I2) 3,3,2
 132     2 I22 = INDEX(I2)
 133       IF(ICMPCH(AI,A(I22)))3,3,21
 134    21 INDEX (I3) = I22
 135       I3 = I2
 136       GO TO 1
 137     3 INDEX (I3) = I33
 138     4 I3 = INDEX (N)
 139       INDEX (N) = INDEX (1)
 140       AI = A(I3)
 141       N = N-1
 142       IF (N-1) 12,12,5
 143     5 I1 = 1
 144     6 I2 = I1 + I1
 145       IF (I2.LE.N) I22= INDEX(I2)
 146       IF (I2-N) 7,9,11
 147     7 I222 = INDEX (I2+1)
 148       IF (ICMPCH(A(I22),A(I222))) 8,9,9
 149     8 I2 = I2+1
 150       I22 = I222
 151     9 IF (ICMPCH(AI,A(I22))) 10,11,11
 152    10 INDEX(I1) = I22
 153       I1 = I2
 154       GO TO 6
 155    11 INDEX (I1) = I3
 156       GO TO 4
 157    12 INDEX (1) = I3
 158       RETURN
 159       END
 160 *     ========================================
 161       FUNCTION ICMPCH(IC1,IC2)
 162 C     FUNCTION TO COMPARE TWO 4 CHARACTER EBCDIC STRINGS - IC1,IC2
 163 C     ICMPCH=-1 IF HEX VALUE OF IC1 IS LESS THAN IC2
 164 C     ICMPCH=0  IF HEX VALUES OF IC1 AND IC2 ARE THE SAME
 165 C     ICMPCH=+1 IF HEX VALUES OF IC1 IS GREATER THAN IC2
 166       I1=IC1
 167       I2=IC2
 168       IF(I1.GE.0.AND.I2.GE.0)GOTO 40
 169       IF(I1.GE.0)GOTO 60
 170       IF(I2.GE.0)GOTO 80
 171       I1=-I1
 172       I2=-I2
 173       IF(I1-I2)80,70,60
 174  40   IF(I1-I2)60,70,80
 175  60   ICMPCH=-1
 176       RETURN
 177  70   ICMPCH=0
 178       RETURN
 179  80   ICMPCH=1
 180       RETURN
 181       END