WSJT-X/lib/sort.f90

subroutine sort(n,arr)

  integer n,m,nstack
  real arr(n)
  parameter (m=7,nstack=50)
  integer i,ir,j,jstack,k,l,istack(nstack)
  real a,temp

  jstack=0
  l=1
  ir=n
  n0=n

1 if(ir-l.lt.m) then
     do j=l+1,ir
        a=arr(j)
        do i=j-1,1,-1
           if(arr(i).le.a) goto 2
           arr(i+1)=arr(i)
        enddo
        i=0
2       arr(i+1)=a
     enddo

     if(jstack.eq.0) return

     ir=istack(jstack)
     l=istack(jstack-1)
     jstack=jstack-2

  else
     k=(l+ir)/2
     temp=arr(k)
     arr(k)=arr(l+1)
     arr(l+1)=temp

     if(arr(l+1).gt.arr(ir)) then
        temp=arr(l+1)
        arr(l+1)=arr(ir)
        arr(ir)=temp
     endif

     if(arr(l).gt.arr(ir)) then
        temp=arr(l)
        arr(l)=arr(ir)
        arr(ir)=temp
     endif

     if(arr(l+1).gt.arr(l)) then
        temp=arr(l+1)
        arr(l+1)=arr(l)
        arr(l)=temp
     endif

     i=l+1
     j=ir
     a=arr(l)
3    i=i+1
     if(i.gt.n0) then
        do jj=1,n0
           write(99,3001) jj,arr(jj),i,n,ir
3001       format(i10,e12.3,3i10)
        enddo
        close(99)
        stop 'Bounds error in sort.f90'
     endif
     if(arr(i).lt.a) goto 3

4    j=j-1
     if(arr(j).gt.a) goto 4

     if(j.lt.i) goto 5
     temp=arr(i)
     arr(i)=arr(j)
     arr(j)=temp
     goto 3

5    arr(l)=arr(j)
     arr(j)=a
     jstack=jstack+2
     if(jstack.gt.nstack) stop 'nstack too small in sort'

     if(ir-i+1.ge.j-l) then
        istack(jstack)=ir
        istack(jstack-1)=i
        ir=j-1
     else
        istack(jstack)=j-1
        istack(jstack-1)=l
        l=i
     endif

  endif
  goto 1

end subroutine sort