Merge Sort Routine

Hi Jeff,

While in lock-down and to keep my mind active, I've written a sorting routine for real arrays. I'm posting the sort routine here.  Although it's far from being the fastest sort routine, it's simple. I've sorted up to 65,000 random numbers with the routine with no problem. However, speed wise, it's more practical in the range of 3 to 4000 numbers (e.g., Random numbers =1034, t = 0.04 sec.; Random numbers =4108, t = 0.4 sec.).  Like many routines, sometimes we learn that similar logic has been applied before and are not aware of it. The program is self explanatory and can be compiled as is and run with SimplyFortran.

I would welcome any constructive suggestions from forum members on how to improve the routine.

Thanks,
Frank

    !-------------------------------------------------------------------
    !----------------- Start of MergSort Routine -----------------------
    !-------------------------------------------------------------------
    MODULE nrtype
        IMPLICIT NONE

        !--- Listing valid kind parameters types
        INTEGER, PARAMETER :: I1B = KIND(2)
        INTEGER, PARAMETER :: I2B = KIND(4)
        INTEGER, PARAMETER :: I4B = KIND(9)

        INTEGER, PARAMETER :: SP = KIND(1.0E0)
        INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(15, 200)
        INTEGER, PARAMETER :: QP = SELECTED_REAL_KIND(2*PRECISION(1.0_DP))

        INTEGER, PARAMETER :: LGT = KIND(.TRUE.)
    END MODULE nrtype

    !-------------------------------------------------------------------
    Module MSort
        USE nrtype
        Implicit None

        PRIVATE

        PUBLIC :: MergSort

        INTERFACE MergSort
            MODULE PROCEDURE MergSort
        END INTERFACE

    !-------------------------------------------------------------------
    CONTAINS
    !-------------------------------------------------------------------

        !---------------------------------------------------------------
        FUNCTION MergSort( array ) RESULT( sorted )
        !---------------------------------------------------------------
        !---    MergSort version 1.0
        !---
        !---    Developed by F.W. Perrella, Ph.D.  November 27, 2020
        !---            Silver Spring, Maryland U.S.A.
        !---------------------------------------------------------------
        ! NAME:
        !       MergSort
        !
        ! PURPOSE:
        !       Program to sort a numeric array in ascending order.
        !
        ! MODULE:
        !       nrType: Definition for kind variable types.
        !---------------------------------------------------------------
        !
        !    CALLING SEQUENCE:
        !       Result = MergSort( array )
        !
        !    INPUT ARGUMENTS:
        !       array:      Real array of numbers to sort.
        !       TYPE:       REAL( KIND = Double )
        !
        !    FUNCTION RESULT:
        !       TYPE:    Real( double )
        !
        !       RESULT: A real array of values sorted in ascending order.
        !---------------------------------------------------------------
        !
        !   BASIC MERGSORT ROUTINE:
        !     Function MergSort(array) Result(sorted)
        !       c = 123456789.0
        !       unsorted = array
        !       sorted = 0.0
        !       Do i = 1, n
        !         j = MINLOC(unsorted,1)
        !         vecMin = unsorted(j)
        !         unsorted = MERGE(unsorted,c,MASK=(unsorted /= vecMin))
        !         sorted(i) = vecMin
        !       End Do
        !     End Function
        !---------------------------------------------------------------
            use nrtype
            implicit none
            real(DP), dimension(:), intent(in) :: array
            real(DP), dimension(1:size(array)) :: sorted

            !--- Local orking arrays
            real(DP), allocatable, dimension(:) :: unsorted
            real(DP), allocatable, dimension(:) :: c

            !--- Local variables
            real(DP)                            :: vecMin
            integer(I4B)                        :: i, j, n

            !--- Number of values to sort
            n = SIZE( array )

            !--- Array too small to be sorted
            if ( n == 1 ) then
                sorted = array
                return
            endif

            !--- Allocate working arrays
            allocate( unsorted(n), c(n) )

            !--- Large number array place holder
            c = 123456789.0

            !--- Begin sorting array
            unsorted = array
            sorted = 0.0

            do i = 1, n
                !--- Find minimum value in array
                j = MINLOC( unsorted, 1 )
                vecMin = unsorted(j)

                !--- Merge array eliminating minimum value
                unsorted = MERGE( unsorted, c, MASK=(unsorted /= vecMin) )

                !--- Save the minimum values in array
                sorted(i) = vecMin
            end do

            !--- Deallocate working arrays
            Deallocate( unsorted, c )

            return
        End Function MergSort

    End Module MSort

    !-------------------------------------------------------------------
    PROGRAM Test_Sort
        use nrtype
        implicit none
        character(1) :: a

        call Test_MergSort()

        WRITE(*,'(/1x,"Press return to exit",$)')
        READ(*,'(a1)') a
    End Program Test_Sort

    !-------------------------------------------------------------------
    Subroutine Test_MergSort()
        use nrtype
        use MSort
        implicit none

        real(SP) :: t1, t2, tsum
        real(DP),allocatable :: array1(:)
        integer(I4B) :: j, k, m, n
        integer(I4B) :: left, right, isize
        logical(LGT) :: bflag, btot

        m = 10
        n = 14
        btot = .TRUE.

        WRITE(*,'(/1x,"Testing MergSort")')
        WRITE(*,'(1x,a)') REPEAT("-", 35)

        do j = m, n
            !--- 1,034 to 16,398 random numbers
            isize = 2**j
            isize = isize + j
            allocate( array1(isize) )

            tsum = 0.0
            do k = 1, m
                call random_number( array1 )

                left = 1
                right = isize

                !--- Start timer
                t1 = DeltaTime( .TRUE. )

                !--- Sort in Ascending Order
                array1 = MergSort( array1 )

                !--- End timer
                t2 = DeltaTime( .FALSE. )

                tsum = tsum + (t2 - t1)
            end do

            WRITE(*,'(1x,"Random numbers =",1x,I0)') isize
            WRITE(*,'(1x,"Average elapsed time =",1x,F6.4,1x,"sec")') tsum/m

            !--- Check that the array was sorted correctly.
            call check_sort( array1, left, right, bflag )

            btot = (btot .eqv. bflag)

            deallocate(array1)
        end do

        WRITE(*, &
            '(1x,"All tests were sorted correctly:",1x,L1,"RUE")') btot
        WRITE(*,'(1x,a)') REPEAT("-", 35)

        return
    !End Subroutine Test_MergSort

    !-------------------------------------------------------------------
    CONTAINS
    !-------------------------------------------------------------------

    !-------------------------------------------------------------------
    Subroutine check_sort( array, left, right, bflag )
        use nrtype
        implicit none
        integer(I4B), intent(in)  :: left, right
        real(DP), intent(inout)   :: array(left:right)
        logical(LGT), intent(out) :: bflag
        integer(I4B) :: j

        bflag = .true.
        do j = 1, size(array)-1
            if( array(j+1) < array(j) ) then
                bflag = .false.
                EXIT
            end if
        end do

        if (bflag) then
            print *, "Correctly sorted array"
        else
            print *, "Incorrectly sorted array"
        end if
        PRINT *

        return
    End Subroutine check_sort

    !-------------------------------------------------------------------
    FUNCTION DeltaTime(Start) RESULT(tm)
        !-------------------------------------
        !--- Routine to calculate run time
        !    print *, 'Starttime:',  t0
        !    print *, 'Finishtime:', t1
        !    print *, 'Elapsed time=', t1 - t0
        !-------------------------------------
        IMPLICIT NONE
        LOGICAL, INTENT(IN) :: Start
        LOGICAL             :: Begin
        REAL, SAVE          :: t0
        REAL                :: t1
        REAL                :: tm
        REAL, SAVE          :: tt

        !--- Start timer
        !--- Start = .TRUE.
        Begin = Start
        IF ( Begin ) THEN
            call cpu_time ( t0 )
            t1 = t0
            Begin = .FALSE.

        !--- Stop timer
        ELSE !--- Start = .FALSE.
            call cpu_time ( t1 )
        END IF

        !--- Calculate time in seconds
        tt = tt + (t1 - t0)

        !--- Return total time in seconds
        tm = tt
    END FUNCTION DeltaTime

    !-------------------------------------------------------------------
    End Subroutine Test_MergSort
    !-------------------------------------------------------------------
    !---------------- End of MergSort Routine --------------------------
    !-------------------------------------------------------------------