c                                                                       
cNKB00020
c             KB07A      HANDLES REAL SINGLE-LENGTH VARIABLES           
cNKB00030
c STANDARD FORTRAN 66 (A VERIFIED PFORT SUBROUTINE)                     
cNKB00040
c  THE WORK-SPACE 'MARK' OF LENGTH 50 PERMITS UP TO 2**(50/2) NUMBERS   
cNKB00050
c  TO BE SORTED. THIS IS MORE THAN THE IBM VIRTUAL MEMORY SPACE         
cNKB00060
c  WILL HOLD .                                                          
cNKB00070
      subroutine kb07a(count, n, index)
c  SET INDEX ARRAY TO ORIGINAL ORDER .                                  
cNKB00090
      dimension count(n), mark(50), index(n)
      do 10 i = 1, n
      index(i) = i
c  CHECK THAT A TRIVIAL CASE HAS NOT BEEN ENTERED .                     
cNKB00130
   10 continue
      if (n .eq. 1) goto 200
      if (n .ge. 1) goto 30
      write(unit=6, fmt=20) 
   20 format(///20x,
     &65h ***KB07A*** NO NUMBERS TO BE SORTED ** RETURN TO CALLING PROGR
     &AM)
c  'M' IS THE LENGTH OF SEGMENT WHICH IS SHORT ENOUGH TO ENTER          
cNKB00200
c  THE FINAL SORTING ROUTINE. IT MAY BE EASILY CHANGED.                 
cNKB00210
      goto 200
c  SET UP INITIAL VALUES.                                               
cNKB00230
   30 m = 12
      la = 2
      is = 1
      if = n
c  IF SEGMENT IS SHORT ENOUGH SORT WITH FINAL SORTING ROUTINE .         
cNKB00280
      do 190 mloop = 1, n
      ifka = if - is
c********* FINAL SORTING ***                                            
cNKB00310
c  ( A SIMPLE BUBBLE SORT )                                             
cNKB00320
      if ((ifka + 1) .gt. m) goto 70
      is1 = is + 1
      do 60 j = is1, if
      i = j
   40 if (count(i - 1) .lt. count(i)) goto 60
      if (count(i - 1) .gt. count(i)) goto 50
      if (index(i - 1) .lt. index(i)) goto 60
   50 av = count(i - 1)
      count(i - 1) = count(i)
      count(i) = av
      int = index(i - 1)
      index(i - 1) = index(i)
      index(i) = int
      i = i - 1
      if (i .gt. is) goto 40
   60 continue
      la = la - 2
c             *******  QUICKSORT  ********                              
cNKB00500
c  SELECT THE NUMBER IN THE CENTRAL POSITION IN THE SEGMENT AS          
cNKB00510
c  THE TEST NUMBER.REPLACE IT WITH THE NUMBER FROM THE SEGMENT'S        
cNKB00520
c  HIGHEST ADDRESS.                                                     
cNKB00530
      goto 170
   70 iy = (is + if) / 2
      x = count(iy)
      intest = index(iy)
      count(iy) = count(if)
c  THE MARKERS 'I' AND 'IFK' ARE USED FOR THE BEGINNING AND END         
cNKB00590
c  OF THE SECTION NOT SO FAR TESTED AGAINST THE PRESENT VALUE           
cNKB00600
c  OF X .                                                               
cNKB00610
      index(iy) = index(if)
      k = 1
c  WE ALTERNATE BETWEEN THE OUTER LOOP THAT INCREASES I AND THE         
cNKB00640
c  INNER LOOP THAT REDUCES IFK, MOVING NUMBERS AND INDICES AS           
cNKB00650
c  NECESSARY, UNTIL THEY MEET .                                         
cNKB00660
      ifk = if
      do 110 i = is, if
      if (x .gt. count(i)) goto 110
      if (x .lt. count(i)) goto 80
      if (intest .gt. index(i)) goto 110
   80 if (i .ge. ifk) goto 120
      count(ifk) = count(i)
      index(ifk) = index(i)
      k1 = k
      do 100 k = k1, ifka
      ifk = if - k
      if (count(ifk) .gt. x) goto 100
      if (count(ifk) .lt. x) goto 90
      if (intest .le. index(ifk)) goto 100
   90 if (i .ge. ifk) goto 130
      count(i) = count(ifk)
      index(i) = index(ifk)
      goto 110
  100 continue
      goto 120
c  RETURN THE TEST NUMBER TO THE POSITION MARKED BY THE MARKER          
cNKB00870
c  WHICH DID NOT MOVE LAST. IT DIVIDES THE INITIAL SEGMENT INTO         
cNKB00880
c  2 PARTS. ANY ELEMENT IN THE FIRST PART IS LESS THAN OR EQUAL         
cNKB00890
c  TO ANY ELEMENT IN THE SECOND PART, AND THEY MAY NOW BE SORTED        
cNKB00900
c  INDEPENDENTLY .                                                      
cNKB00910
  110 continue
  120 count(ifk) = x
      index(ifk) = intest
      ip = ifk
      goto 140
  130 count(i) = x
      index(i) = intest
c  STORE THE LONGER SUBDIVISION IN WORKSPACE.                           
cNKB00990
      ip = i
  140 if ((ip - is) .gt. (if - ip)) goto 150
      mark(la) = if
      mark(la - 1) = ip + 1
      if = ip - 1
      goto 160
  150 mark(la) = ip - 1
      mark(la - 1) = is
c  FIND THE LENGTH OF THE SHORTER SUBDIVISION.                          
cNKB01080
      is = ip + 1
  160 lngth = if - is
c  IF IT CONTAINS MORE THAN ONE ELEMENT SUPPLY IT WITH WORKSPACE .      
cNKB01110
      if (lngth .le. 0) goto 180
      la = la + 2
      goto 190
c  OBTAIN THE ADDRESS OF THE SHORTEST SEGMENT AWAITING QUICKSORT        
cNKB01150
  170 if (la .le. 0) goto 200
  180 if = mark(la)
      is = mark(la - 1)
  190 continue
  200 return 
      end
