! 例題 8-13  クイック・ソート ［再帰的呼出しの実用例 ］
RECURSIVE SUBROUTINE quick_sort( array, n )

  IMPLICIT NONE
  INTEGER, INTENT ( IN ) :: n
  INTEGER, INTENT ( INOUT ) :: array( 1 : n )
  INTEGER ::  pivot, i, j

  IF ( n == 2 ) THEN
    IF ( array( 1 ) > array( 2 ) )  &
                      CALL swap( array( 1 ), array( 2 ) )
    RETURN
  END IF

  pivot = array( 1 + n / 2 ) 
  i = 1
  j = n

  DO                                                 ! 仕分け開始

s1: DO                                               ! 右へサーチ
      IF ( array( i ) >= pivot .OR. i == n ) EXIT s1
      i = i + 1
    END DO s1

s2: DO                                               ! 左へサーチ
      IF ( array( j ) <= pivot .OR. j == 1 ) EXIT s2
      j = j - 1
    END DO s2

    IF ( i > j ) EXIT                                ! 仕分け終了

    CALL swap( array( i ), array( j ) )                ! 値の交換
    i = i + 1
    j = j - 1

  END DO
                                                 ! 部分列のソート
  IF ( j > 1 ) CALL quick_sort( array( 1 : j ) , j )
  IF ( i < n ) CALL quick_sort( array( i : n ) , n - i + 1 )

CONTAINS

  SUBROUTINE swap( x, y )

    IMPLICIT NONE
    INTEGER, INTENT ( INOUT ) :: x, y
    INTEGER :: temp

    temp = x
    x = y
    y = temp

  END SUBROUTINE swap

END SUBROUTINE quick_sort

PROGRAM ex8_13

  IMPLICIT NONE
  INTEGER, PARAMETER :: n = 25
  INTEGER :: a( 1 : n ), seed, i
  REAL :: uran

  PRINT *, 'Seed?'
  READ *, seed
                                                     ! 数列の準備
  DO i = 1, n
    a( i ) = INT( 100.0E0 * uran( seed ) )
  END DO

  PRINT '( 50I3 )', a

  CALL quick_sort( a , n )             ! 配列とサイズの引きわたし

  PRINT '( 50I3 )', a

END PROGRAM ex8_13

REAL FUNCTION uran( iseed )              ! 一様実数乱数を返す関数

  IMPLICIT NONE
  INTEGER, INTENT ( INOUT ) :: iseed
  INTEGER, PARAMETER :: mult = 48828125, mask = 2147483647
  REAL, PARAMETER :: rmax = 2.0E0 ** 31

  iseed = IAND( mult * iseed, mask )
  uran  = REAL( iseed ) / rmax

END FUNCTION uran