lexical_sort_nonrecursive Subroutine

public pure subroutine lexical_sort_nonrecursive(str, case_sensitive)

Sorts a character array str in increasing order.

Uses a non-recursive quicksort, reverting to insertion sort on arrays of size . Dimension of stack limits array size to about .

License

History

  • Based on the LAPACK routine DLASRT.
  • Extensively modified by Jacob Williams,Feb. 2016. Converted to modern Fortran and removed the descending sort option.

Arguments

Type IntentOptional Attributes Name
character(len=*), intent(inout), dimension(:) :: str

on entry,the array to be sorted. on exit,str has been sorted into increasing order (str(1) <= ... <= str(n))
logical, intent(in) :: case_sensitive

if true, the sort is case sensitive

Source Code

    pure subroutine lexical_sort_nonrecursive(str,case_sensitive)

    implicit none

    character(len=*),dimension(:),intent(inout) :: str  !! on entry,the array to be sorted.
                                                        !! on exit,`str` has been sorted into
                                                        !! increasing order (`str(1) <= ... <= str(n)`)
    logical,intent(in) :: case_sensitive !! if true, the sort is case sensitive

    integer :: endd,i,j,n,start,stkpnt
    character(len=len(str)) :: d1,d2,d3,dmnmx,tmp
    integer,dimension(2,32) :: stack

    ! number of elements to sort:
    n = size(str)

    if ( n>1 ) then

        stkpnt     = 1
        stack(1,1) = 1
        stack(2,1) = n

        do

            start  = stack(1,stkpnt)
            endd   = stack(2,stkpnt)
            stkpnt = stkpnt - 1
            if ( endd-start<=max_size_for_insertion_sort .and. endd>start ) then

                ! do insertion sort on str( start:endd )
                insertion: do i = start + 1,endd
                    do j = i,start + 1,-1
                        if ( lexical_lt(str(j),str(j-1),case_sensitive) ) then
                            dmnmx    = str(j)
                            str(j)   = str(j-1)
                            str(j-1) = dmnmx
                        else
                            exit
                        end if
                    end do
                end do insertion

            elseif ( endd-start>max_size_for_insertion_sort ) then

                ! partition str( start:endd ) and stack parts,largest one first
                ! choose partition entry as median of 3

                d1 = str(start)
                d2 = str(endd)
                i  =(start+endd)/2
                d3 = str(i)
                if ( lexical_lt(d1,d2,case_sensitive) ) then
                    if ( lexical_lt(d3,d1,case_sensitive) ) then
                        dmnmx = d1
                    elseif ( lexical_lt(d3,d2,case_sensitive) ) then
                        dmnmx = d3
                    else
                        dmnmx = d2
                    endif
                elseif ( lexical_lt(d3,d2,case_sensitive) ) then
                    dmnmx = d2
                elseif ( lexical_lt(d3,d1,case_sensitive) ) then
                    dmnmx = d3
                else
                    dmnmx = d1
                endif

                i = start - 1
                j = endd + 1
                do
                    do
                        j = j - 1
                        if ( lexical_le(str(j),dmnmx,case_sensitive) ) exit
                    end do
                    do
                        i = i + 1
                        if ( lexical_ge(str(i),dmnmx,case_sensitive) ) exit
                    end do
                    if ( i<j ) then
                        tmp   = str(i)
                        str(i) = str(j)
                        str(j) = tmp
                    else
                        exit
                    endif
                end do
                if ( j-start>endd-j-1 ) then
                    stkpnt          = stkpnt + 1
                    stack(1,stkpnt) = start
                    stack(2,stkpnt) = j
                    stkpnt          = stkpnt + 1
                    stack(1,stkpnt) = j + 1
                    stack(2,stkpnt) = endd
                else
                    stkpnt          = stkpnt + 1
                    stack(1,stkpnt) = j + 1
                    stack(2,stkpnt) = endd
                    stkpnt          = stkpnt + 1
                    stack(1,stkpnt) = start
                    stack(2,stkpnt) = j
                endif

            endif

            if ( stkpnt<=0 ) exit

        end do

    end if

    end subroutine lexical_sort_nonrecursive