IVF が少しバージョンアップして、ABSTRACT INTERFACE のバグが取れていました。
ABSTRACT INTERFACE があると、同じインターフェースを何度も書かなくてすみます。
実行結果
ソースプログラム
MODULE m_sort IMPLICIT NONE ABSTRACT INTERFACE ELEMENTAL LOGICAL FUNCTION t_cmp(x1, x2) REAL, INTENT(IN) :: x1, x2 END FUNCTION t_cmp END INTERFACE CONTAINS !----------------------------------------------------- RECURSIVE FUNCTION quick_sort(x, f) RESULT(res) REAL, INTENT(IN) :: x(:) REAL :: res(SIZE(x)) PROCEDURE (t_cmp) :: f LOGICAL :: mask(SIZE(x) - 1) IF (SIZE(x) > 1) THEN mask = f(x(2:), x(1)) res = [ quick_sort( PACK(x(2:), mask), f ), & x(1), & quick_sort( PACK(x(2:), .NOT. mask), f ) ] ELSE res = x END IF RETURN END FUNCTION quick_sort ! Reference : Arjen Markus, ACM Fortran Forum 27 (2008) 2-5. !----------------------------------------------------- END MODULE m_sort !======================================================== MODULE m_func IMPLICIT NONE CONTAINS !----------------------------------------------------- ELEMENTAL LOGICAL FUNCTION lt(a, b) REAL, INTENT(IN) :: a, b IF (a < b) THEN lt = .TRUE. ELSE lt = .FALSE. ENDIF RETURN END FUNCTION lt !----------------------------------------------------- ELEMENTAL LOGICAL FUNCTION gt(a, b) REAL, INTENT(IN) :: a, b IF (a > b) THEN gt = .TRUE. ELSE gt = .FALSE. ENDIF RETURN END FUNCTION gt !----------------------------------------------------- END MODULE m_func !======================================================== PROGRAM sort USE m_sort USE m_func IMPLICIT NONE REAL :: x(30) PROCEDURE (t_cmp), POINTER :: fp CALL RANDOM_SEED() CALL RANDOM_NUMBER(x) fp => lt PRINT *, quick_sort(x, fp) PRINT * !fp => gt PRINT *, quick_sort(x, gt) STOP END PROGRAM sort
