program sort
  use gildas_def
  use gbl_format
  use image_def
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! GILDAS	Stand alone program
  !	Sort a table according to a given column
  !---------------------------------------------------------------------
  ! Global
  character(len=*), parameter :: pname = 'SORT'
  ! Local
  integer :: i,scol,nlin
  logical :: error, llin
  integer :: lt, ier
  integer(kind=4), allocatable :: iw(:)
  real(kind=4), allocatable :: rwork(:)
  character(len=filename_length) :: name
  character(len=12) :: algo,text
  type(gildas) :: x
  !
  ! Open parameter file
  call gildas_open
  call gildas_char('TABLE$',name)
  call gildas_inte('COLUMN$',scol,1)
  call gildas_char('ALGORITHM$',algo)
  call gildas_logi('LINE$',llin,1)
  call gildas_close
  !
  if (llin) then
    text = 'line'
    lt = 4
  else
    text = 'column'
    lt = 6
  endif
  !
  call gildas_null(x, type='TABLE')
  x%loca%read = .false.
  call gdf_read_gildas(x,name,'.tab',error,data=.true.)
  if (error) then
    call gagout('F-'//pname//',  Cannot read input file')
    goto 100
  endif
  if (scol.lt.1 .or. scol.gt.x%gil%dim(2)) then
    write(6,*) 'E-'//pname//',  Sorting '//text(1:lt)//' does not exist'
    call sysexi (fatale)
  endif
  !
  nlin = x%gil%dim(1)
  if (llin) then
    if (algo .eq. 'QUICK') then
      allocate (rwork(x%gil%dim(1)),stat=ier)
      call trione (x%r2d,x%gil%dim(1),x%gil%dim(2),scol,   &
     &        rwork,error)
      if (error) then
        call gagout ('F-'//pname//',  Table not sorted')
        goto 100
      endif
    else
      write(6,*) 'F-'//pname//',  Method not supported: '//algo
      goto 100
    endif
  else
    if (algo .eq. 'QUICK') then
      allocate (rwork(x%gil%dim(1)),iw(x%gil%dim(1)),stat=ier)
      call gr4_trie (x%r2d(:,scol),iw,nlin,error)
      if (error) then
        call gagout ('F-'//pname//',  Table not sorted')
        goto 100
      endif
      do i=1,scol-1
        call gr4_sort(x%r2d(:,i),rwork,iw,nlin)
      enddo
      do i=scol+1,x%gil%dim(2)
        call gr4_sort(x%r2d(:,i),rwork,iw,nlin)
      enddo
    elseif (algo .eq. 'HEAP') then
      allocate (rwork(x%gil%dim(1)),iw(x%gil%dim(1)),stat=ier)
      call heap (x%gil%dim(1),x%r2d(:,scol), iw)
      do i=1,scol-1
        call gr4_sort(x%r2d(:,i),rwork,iw,nlin)
      enddo
      do i=scol+1,x%gil%dim(2)
        call gr4_sort(x%r2d(:,i),rwork,iw,nlin)
      enddo
    else
      write (6,*) 'F-'//pname//',  Unsupported method: '//algo
      goto 100
    endif
  endif
  call gdf_write_image(x,x%r2d,error)
  !
  call gagout ('S-'//pname//',  Successful completion')
  call sysexi (1)
100 call sysexi (fatale)
end program sort
!
subroutine heap (n,cle,ipic)
  use gildas_def
  !---------------------------------------------------------------------
  !	Heap sort routine
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: n  ! Size 
  real(4), intent(inout) :: cle(n)             ! Values
  integer, intent(inout) :: ipic(n)            ! Pointer
  ! Local
  real(4) :: ctemp
  integer :: m, k, i, ip, itemp
  ! Tri en epi. Algorithme publie par J. ARSAC
  !		(Premieres lecons de programmation,
  !		CEDIC/Fernand Nathan, 1980)
  ! Convergence en N*LOG2(N) garantie dans tous les cas
  ! ce qui n'est pas le cas de QUICKSORT...
  k=(n/2)+1
  ! Epi de K a N
21 if (k.eq.1) goto 29    ! Epi de 1 a N
  k=k-1
  i=k
23 ip=2*i
  if (ip.gt.n) goto 21         ! Epi de K a N
  if (ip.eq.n) goto 26
  if (cle(ip+1).gt.cle(ip)) ip=ip+1
26 if (cle(i).gt.cle(ip)) goto 21 ! Epi de K a N
  ctemp=cle(i)
  cle(i)=cle(ip)
  cle(ip)=ctemp
  itemp=ipic(i)
  ipic(i)=ipic(ip)
  ipic(ip)=itemp
  i=ip
  goto 23
29 m=n
  ! En place de M+1 a N. 		! Epi de 1 a N
30 continue
  if (m.eq.1) goto 49          ! Trie de 1 a N
  ctemp=cle(1)
  cle(1)=cle(m)
  cle(m)=ctemp
  itemp=ipic(1)
  ipic(1)=ipic(m)
  ipic(m)=itemp
  m=m-1
  i=1
  ! Epi de 1 a M sauf I
35 continue
  ip=2*i
  if (ip.gt.m) goto 30         ! Epi de 1 a M
  if (ip.eq.m) goto 39
  if (cle(ip+1).gt.cle(ip)) ip=ip+1
39 if (cle(i).gt.cle(ip)) goto 30 ! Epi de 1 a M
  ctemp=cle(i)
  cle(i)=cle(ip)
  cle(ip)=ctemp
  itemp=ipic(i)
  ipic(i)=ipic(ip)
  ipic(ip)=itemp
  i=ip
  goto 35
  ! Trie de 1 a N
49 continue
end subroutine heap
!
subroutine trione (x,nd,n,ix,work,error)
  use gildas_def
  !---------------------------------------------------------------------
  ! 	Sorting program that uses a quicksort algorithm.
  !	Sorts by column.
  !---------------------------------------------------------------------
  integer(kind=index_length), intent(in) :: nd ! First dimension of array
  integer(kind=index_length), intent(in) :: n  ! Second dimension of array
  real(4), intent(out) :: x(nd,n)              ! Array to be sorted
  integer, intent(in) :: ix                    ! Sort column
  real(4), intent(inout) :: work(nd)           ! Work array
  logical, intent(inout) :: error              ! Error flag
  ! Local
  integer :: maxstack,nstop
  parameter (maxstack=1000,nstop=15)
  integer(4) :: i, j, k
  integer(4) :: l, r, m, lstack(maxstack), rstack(maxstack), sp
  real(4) ::  key
  logical :: mgtl, lgtr, rgtm
  !
  if (n.le.nstop) goto 50
  sp = 0
  sp = sp + 1
  lstack(sp) = 1
  rstack(sp) = n
  !
  ! Sort a subrecord off the stack
  ! Set KEY = median of X(L), X(M), X(R)
  ! No! This is not reasonable, as systematic very inequal partitioning will
  ! occur in some cases (especially for nearly already sorted files)
  ! To fix this problem, I found (but I cannot prove it) that it is best to
  ! select the estimation of the median value from intermediate records. P.V.
1 l = lstack(sp)
  r = rstack(sp)
  sp = sp - 1
  m = (l + r) / 2
  !
  mgtl = x(ix,m) .gt. x(ix,l)
  rgtm = x(ix,r) .gt. x(ix,m)
  !
  ! Algorithm to select the median key. The original one from MONGO
  ! was completely wrong. P. Valiron, 24-Jan-84 .
  !
  !		   	MGTL	RGTM	LGTR	MGTL.EQV.LGTR	MEDIAN_KEY
  !
  !	KL < KM < KR	T	T	*	*		KM
  !	KL > KM > KR	F	F	*	*		KM
  !
  !	KL < KM > KR	T	F	F	F		KR
  !	KL < KM > KR	T	F	T	T		KL
  !
  !	KL > KM < KR	F	T	F	T		KL
  !	KL > KM < KR	F	T	T	F		KR
  !
  if (mgtl .eqv. rgtm) then
    key = x(ix,m)
  else
    lgtr = x(ix,l) .gt. x(ix,r)
    if (mgtl .eqv. lgtr) then
      key = x(ix,l)
    else
      key = x(ix,r)
    endif
  endif
  i = l
  j = r
  !
  ! Find a big record on the left
10 if (x(ix,i).ge.key) goto 11
  i = i + 1
  goto 10
11 continue
  ! Find a small record on the right
20 if (x(ix,j).le.key) goto 21
  j = j - 1
  goto 20
21 continue
  if (i.ge.j) goto 2
  !
  ! Exchange records
  call r4tor4(x(1,i),work,nd)
  call r4tor4(x(1,j),x(1,i),nd)
  call r4tor4(work,x(1,j),nd)
  i = i + 1
  j = j - 1
  goto 10
  !
  ! Subfile is partitioned into two halves, left .le. right
  ! Push the two halves on the stack
2 continue
  if (j-l+1 .gt. nstop) then
    sp = sp + 1
    if (sp.gt.maxstack) then
      write(6,*) 'E-SORT,  Stack overflow ',sp
      error = .true.
      return
    endif
    lstack(sp) = l
    rstack(sp) = j
  endif
  if (r-j .gt. nstop) then
    sp = sp + 1
    if (sp.gt.maxstack) then
      write(6,*) 'E-SORT,  Stack overflow ',sp
      error = .true.
      return
    endif
    lstack(sp) = j+1
    rstack(sp) = r
  endif
  !
  ! Anything left to process?
  if (sp.gt.0) goto 1
  !
50 continue
  !
  do j=n-1,1,-1
    k = j
    do i = j+1,n
      if (x(ix,j).le.x(ix,i)) exit ! I
      k = i
    enddo
    if (k.eq.j) cycle          ! J
    call r4tor4(x(1,j),work,nd)
    do i = j+1,k
      call r4tor4(x(1,i),x(1,i-1),nd)
    enddo
    call r4tor4(work,x(1,k),nd)
  enddo
  error = .false.
end subroutine trione
