Fortran 95 source code to test sorting algorithms.

sort_test.f95

!****************************************************
! ソート処理各種テスト
!
!   date          name            version
!   2018.12.07    mk-mode.com     1.00 新規作成
!
! Copyright(C) 2018 mk-mode.com All Rights Reserved.
!****************************************************
!
module const
  implicit none
  ! SP: 単精度(4), DP: 倍精度(8)
  integer,     parameter :: SP = kind(1.0)
  integer(SP), parameter :: DP = selected_real_kind(2 * precision(1.0_SP))
  integer(SP), parameter :: N = 1000   ! データ個数
  integer(SP), parameter :: M = 10000  ! 値 MAX ( M 未満 )
  integer(SP), parameter :: L = 10000  ! ソート試行回数
end module const

module sort
  use const, only : SP, DP
  implicit none
  private
  public :: sort_bubble, sort_selection, sort_insertion, sort_quick, &
          & sort_heap_up, sort_heap_down, sort_shell

contains
  ! =============================
  ! public subroutines/functions
  ! =============================

  ! 基本交換法（バブル・ソート）
  !
  ! :param(in)  integer(4)    num: 配列サイズ
  ! :param(in)  integer(4) a(num): 元の配列
  ! :param(out) integer(4) b(num): ソート後の配列
  subroutine sort_bubble(num, a, b)
    implicit none
    integer(SP), intent(in)  :: num, a(num)
    integer(SP), intent(out) :: b(num)
    integer(SP) :: i, j, w

    ! 配列コピー
    b(:) = a(:)

    ! ソート処理
    do i = 1, num - 1
      do j = num, i + 1, -1
        if (b(j) >= b(j - 1)) cycle
        w        = b(j - 1)
        b(j - 1) = b(j)
        b(j)     = w
      end do
    end do
  end subroutine sort_bubble

  ! 基本交換法（直接選択法）
  !
  ! :param(in)  integer(4)    num: 配列サイズ
  ! :param(in)  integer(4) a(num): 元の配列
  ! :param(out) integer(4) b(num): ソート後の配列
  subroutine sort_selection(num, a, b)
    implicit none
    integer(SP), intent(in)  :: num, a(num)
    integer(SP), intent(out) :: b(num)
    integer(SP) :: i, j, s, min, w

    ! 配列コピー
    b(:) = a(:)

    ! ソート処理
    do i = 1, num - 1
      min = b(i)
      s   = i
      do j = i + 1, num
        if (b(j) >= min) cycle
        min = b(j)
        s   = j
      end do
      w    = b(i)
      b(i) = b(s)
      b(s) = w
    end do
  end subroutine sort_selection

  ! 基本挿入法
  !
  ! :param(in)  integer(4)    num: 配列サイズ
  ! :param(in)  integer(4) a(num): 元の配列
  ! :param(out) integer(4) b(num): ソート後の配列
  subroutine sort_insertion(num, a, b)
    implicit none
    integer(SP), intent(in)  :: num, a(num)
    integer(SP), intent(out) :: b(num)
    integer(SP) :: i, j, w

    ! 配列コピー
    b(:) = a(:)

    ! ソート処理
    do i = 2, num
      do j = i - 1, 1, -1
        if (b(j) <= b(j + 1)) exit
        w        = b(j)
        b(j)     = b(j + 1)
        b(j + 1) = w
      end do
    end do
  end subroutine sort_insertion

  ! 改良交換法 (クイック・ソート)
  !
  ! :param(in)  integer(4)    num: 配列サイズ
  ! :param(in)  integer(4) b(num): 元の配列
  ! :param(out) integer(4) a(num): ソート後の配列
  subroutine sort_quick(num, a, b)
    implicit none
    integer(SP), intent(in)  :: num, a(num)
    integer(SP), intent(out) :: b(num)
    integer(SP) :: i, j, w

    ! 配列コピー
    b(:) = a(:)

    ! ソート処理
    call quick(1, num, num, b)
  end subroutine sort_quick

  ! 改良選択法 (ヒープ・ソート)(上方移動)
  !
  ! :param(in)  integer(4)    num: 配列サイズ
  ! :param(in)  integer(4) a(num): 元の配列
  ! :param(out) integer(4) b(num): ソート後の配列
  subroutine sort_heap_up(num, a, b)
    implicit none
    integer(SP), intent(in)  :: num, a(num)
    integer(SP), intent(out) :: b(num)
    integer(SP) :: h(0:num), nn, m, w, p, s

    ! 初期ヒープ作成(上方移動、昇順)
    call gen_heap_up(num, a, h)

    ! ソート処理
    nn = num  ! データ個数
    m  = num  ! N の保存
    do while (nn > 1)
      ! スワップ
      w     = h(1)
      h(1)  = h(nn)
      h(nn) = w
      nn = nn - 1  ! 木の終端切り離し
      p = 1
      s = 2 * p
      do while (s <= nn)
        if (s < nn .and. h(s + 1) > h(s)) s = s + 1
        if (h(p) >= h(s)) exit
        ! スワップ
        w    = h(p)
        h(p) = h(s)
        h(s) = w
        p = s
        s = 2 * p
      end do
    end do
    b(:) = h(1:num)
  end subroutine sort_heap_up

  ! 改良選択法 (ヒープ・ソート)(下方移動)
  !
  ! :param(in)  integer(4)    num: 配列サイズ
  ! :param(in)  integer(4) a(num): 元の配列
  ! :param(out) integer(4) b(num): ソート後の配列
  subroutine sort_heap_down(num, a, b)
    implicit none
    integer(SP), intent(in)  :: num, a(num)
    integer(SP), intent(out) :: b(num)
    integer(SP) :: h(0:num), nn, m, w, p, s

    ! 元の配列を元の木としてコピー
    h(1:num) = a(:)
    ! 初期ヒープ作成(下方移動、昇順)
    call gen_heap_down(num, h)
    ! ソート処理
    nn = num  ! データ個数
    m  = num  ! N の保存
    do while (nn > 1)
      ! スワップ
      w     = h(1)
      h(1)  = h(nn)
      h(nn) = w
      nn = nn - 1  ! 木の終端切り離し
      p = 1
      s = 2 * p
      do while (s <= nn)
        if (s < nn .and. h(s + 1) > h(s)) s = s + 1
        if (h(p) >= h(s)) exit
        ! スワップ
        w    = h(p)
        h(p) = h(s)
        h(s) = w
        p = s
        s = 2 * p
      end do
    end do
    b(:) = h(1:num)
  end subroutine sort_heap_down

  ! 改良挿入法（シェル・ソート）
  !
  ! :param(in)  integer(4)    num: 配列サイズ
  ! :param(in)  integer(4) a(num): 元の配列
  ! :param(out) integer(4) b(num): ソート後の配列
  subroutine sort_shell(num, a, b)
    implicit none
    integer(SP), intent(in)  :: num, a(num)
    integer(SP), intent(out) :: b(num)
    integer(SP) :: gap, i, j, k, w

    ! 配列コピー
    b(:) = a(:)

    ! ソート処理
    gap = num / 2
    do while (gap > 0)
      do k = 1, gap
        i = k + gap
        do while (i <= num)
          j = i - gap
          do while (j >= k)
            if (b(j) <= b(j + gap)) exit
            ! スワップ
            w          = b(j)
            b(j)       = b(j + gap)
            b(j + gap) = w
            j = j - gap
          end do
          i = i + gap
        end do
      end do
      gap = gap / 2
    end do
  end subroutine sort_shell

  ! =============================
  ! Private subroutines/functions
  ! =============================

  ! クイック・ソート用再帰関数
  !
  ! :param(in)    integer(4)     left: 左インデックス
  ! :param(in)    integer(4)    right: 右インデックス
  ! :param(in)    integer(4)      num: 配列サイズ
  ! :param(inout) integer(4)   a(num): 配列
  recursive subroutine quick(left, right, num, a)
    implicit none
    integer(SP), intent(in)    :: left, right, num
    integer(SP), intent(inout) :: a(num)
    integer(SP) :: i, j, s, w

    if (left >= right) return

    ! 最左項を軸に. 軸より小さいグループ. 軸より大きいグループ.
    s = a(left)
    i = left
    j = right + 1
    do
      i = i + 1
      do while (a(i) < s)
        i = i + 1
      end do
      j = j - 1
      do while (a(j) > s)
        j = j - 1
      end do
      if (i >= j) exit
      ! スワップ
      w    = a(i)
      a(i) = a(j)
      a(j) = w
    end do

    ! 軸を正しい位置に挿入
    a(left) = a(j)
    a(j)    = s
    call quick(left,  j - 1, num, a)  ! 左部分列に対する再帰呼び出し
    call quick(j + 1, right, num, a)  ! 右部分列に対する再帰呼び出し
  end subroutine quick

  ! ヒープ生成(上方移動、昇順)
  !
  ! :param(in)  integer(4) num: データ個数
  ! :param(in)  integer(4)   a: 元の配列
  ! :param(out) integer(4)   h: ヒープ配列
  subroutine gen_heap_up(num, a, h)
    implicit none
    integer(SP), intent(in)  :: num, a(num)
    integer(SP), intent(out) :: h(0:num)
    integer(SP) :: i, s, p, w

    h(:) = 0  ! ヒープ配列初期化
    do i = 1, num
      ! 元データ配列から１つヒープ要素として追加
      h(i) = a(i)
      s = i        ! 追加要素の位置
      p = s / 2    ! 親要素の位置
      do while (s >= 2 .and. h(p) < h(s))
        ! スワップ
        w    = h(p)
        h(p) = h(s)
        h(s) = w
        s = p      ! 追加要素の位置
        p = s / 2  ! 親要素の位置
      end do
    end do
  end subroutine gen_heap_up

  ! ヒープ生成(下方移動)
  !
  ! :param(in)    integer(4) num: データ個数
  ! :param(inout) integer(4)   h: ヒープ配列
  subroutine gen_heap_down(num, h)
    implicit none
    integer(SP), intent(in)    :: num
    integer(SP), intent(inout) :: h(0:num)
    integer(SP) :: i, s, p, w

    do i = num / 2, 1, -1
      p = i         ! 親要素の位置
      s = 2 * p     ! 左の子要素の位置
      do while (s <= num)
        ! 左右子要素の大きい方
        if (s < num .and. h(s + 1) > h(s)) s = s + 1
        if (h(p) >= h(s)) exit
        ! スワップ
        w    = h(p)
        h(p) = h(s)
        h(s) = w
        p = s       ! 親要素の位置
        s = 2 * p   ! 左の子要素の位置
      end do
    end do
  end subroutine gen_heap_down
end module sort

program sort_test
  use const
  use sort
  implicit none
  integer(SP) :: a(N), b(N)  ! 元の配列、ソート後配列
  integer(SP) :: seed_size, clock, i
  real(DP)    :: r, t_0, t_1
  integer(SP), allocatable :: seed(:)

  ! 乱数の種の設定
  ! (元の配列を毎回異なる内容にするため)
  call system_clock(clock)
  call random_seed(size=seed_size)
  allocate(seed(seed_size))
  seed = clock
  call random_seed(put=seed)
  deallocate(seed)

  ! 元の配列生成（[0, M) の値の配列）
  do i = 1, N
    call random_number(r)
    a(i) = int(r * M) + 1
  end do
  print '(A)', "#### Source"
  call display(a)

  ! 基本交換法（バブル・ソート）
  write (*, '(A)', advance="no") "  1  : Bubble Sort    "
  call cpu_time(t_0)
  do i = 1, L
    call sort_bubble(N, a, b)
  end do
  call cpu_time(t_1)
  print '(" : ", F6.2, " sec.")', t_1 - t_0
  !call display(b)  ! 結果出力

  ! 基本選択法（直接選択法）
  write (*, '(A)', advance="no") "  2  : Selection Sort "
  call cpu_time(t_0)
  do i = 1, L
    call sort_selection(N, a, b)
  end do
  call cpu_time(t_1)
  print '(" : ", F6.2, " sec.")', t_1 - t_0
  !call display(b)  ! 結果出力

  ! 基本挿入法
  write (*, '(A)', advance="no") "  3  : Insertion Sort "
  call cpu_time(t_0)
  do i = 1, L
    call sort_insertion(N, a, b)
  end do
  call cpu_time(t_1)
  print '(" : ", F6.2, " sec.")', t_1 - t_0
  !call display(b)  ! 結果出力

  ! 改良交換法（クイック・ソート）
  write (*, '(A)', advance="no") "  4  : Quick Sort     "
  call cpu_time(t_0)
  do i = 1, L
    call sort_quick(N, a, b)
  end do
  call cpu_time(t_1)
  print '(" : ", F6.2, " sec.")', t_1 - t_0
  !call display(b)  ! 結果出力

  ! 改良選択法（ヒープ・ソート）（上方移動）
  write (*, '(A)', advance="no") "  5-1: Heap Sort(Up)  "
  call cpu_time(t_0)
  do i = 1, L
    call sort_heap_up(N, a, b)
  end do
  call cpu_time(t_1)
  print '(" : ", F6.2, " sec.")', t_1 - t_0
  !call display(b)  ! 結果出力

  ! 改良選択法（ヒープ・ソート）（下方移動）
  write (*, '(A)', advance="no") "  5-2: Heap Sort(Down)"
  call cpu_time(t_0)
  do i = 1, L
    call sort_heap_down(N, a, b)
  end do
  call cpu_time(t_1)
  print '(" : ", F6.2, " sec.")', t_1 - t_0
  !call display(b)  ! 結果出力

  ! 改良挿入法（シェル・ソート）
  write (*, '(A)', advance="no") "  6  : Shell Sort     "
  call cpu_time(t_0)
  do i = 1, L
    call sort_shell(N, a, b)
  end do
  call cpu_time(t_1)
  print '(" : ", F6.2, " sec.")', t_1 - t_0
  !call display(b)  ! 結果出力

contains
  ! 配列出力
  ! * 1行10件 で出力
  !
  ! :param(in) integer(4) a(:)
  subroutine display(a)
    implicit none
    integer(SP), intent(in) :: a(:)
    character(20) :: f  ! 書式文字列
    integer(SP)   :: d  ! 桁数

    d = int(log10(real(M, DP)))
    write (f, '("(/, 10(2X, I", I0, "))")') d
    print f, a
    print *
  end subroutine display
end program sort_test