MODULE Kinds
  IMPLICIT NONE
  INTEGER, PARAMETER :: rk = KIND(1.0D0)
END MODULE Kinds

MODULE TestProcs
  USE Kinds
  IMPLICIT NONE
CONTAINS
  SUBROUTINE modproc_timetest(ap, bp, cp, res)
    REAL(rk), INTENT(IN) :: ap, bp, cp
    REAL(rk), INTENT(OUT) :: res
    res = ap * bp * cp
  END SUBROUTINE modproc_timetest
END MODULE TestProcs

MODULE module_A_class
  USE Kinds
  IMPLICIT NONE
  TYPE A
  CONTAINS
      PROCEDURE, PUBLIC :: timetest => timetest_A
      PROCEDURE, NOPASS, PUBLIC :: nopass_test => nopass_test_A
  END TYPE A
CONTAINS
  SUBROUTINE timetest_A(this, ap, bp, cp, res)
    CLASS(A) , INTENT(IN) :: this
    REAL(rk), INTENT(IN) :: ap, bp, cp
    REAL(rk), INTENT(OUT) :: res
    res = ap * bp * cp
  END SUBROUTINE timetest_A
  SUBROUTINE nopass_test_A(ap, bp, cp, res)
    REAL(rk), INTENT(IN) :: ap, bp, cp
    REAL(rk), INTENT(OUT) :: res
    res = ap * bp * cp
  END SUBROUTINE nopass_test_A
END MODULE module_A_class

MODULE module_AA_class
  USE module_A_class
  IMPLICIT NONE
  TYPE, EXTENDS(A) :: AA
  CONTAINS
    PROCEDURE, PUBLIC :: timetest => timetest_AA
    PROCEDURE, NOPASS, PUBLIC :: nopass_test => nopass_test_AA
  END TYPE AA
CONTAINS
  SUBROUTINE timetest_AA(this, ap, bp, cp, res)
    CLASS(AA), INTENT(IN) :: this
    REAL(rk), INTENT(IN) :: ap, bp, cp
    REAL(rk), INTENT(OUT) :: res
    res = ap * bp * cp
  END SUBROUTINE timetest_AA
  SUBROUTINE nopass_test_AA(ap, bp, cp, res)
    REAL(rk), INTENT(IN) :: ap, bp, cp
    REAL(rk), INTENT(OUT) :: res
    res = ap * bp * cp
  END SUBROUTINE nopass_test_AA
END MODULE module_AA_class

MODULE SimulatePolyTypes
  USE TestProcs
  IMPLICIT NONE
  
  TYPE SimulateUsingProcPointer
    PROCEDURE(modproc_timetest), NOPASS, POINTER :: proc_ptr
  END TYPE SimulateUsingProcPointer
  
  TYPE :: DispatchTable
    PROCEDURE(modproc_timetest), NOPASS, POINTER :: binding
  END TYPE DispatchTable
  
  TYPE(DispatchTable), TARGET :: dispatch(2)
  
  TYPE SimulateUsingDispatchTable
    TYPE(DispatchTable), POINTER :: dispatch => NULL()
  END TYPE SimulateUsingDispatchTable
CONTAINS
  ! Initialise the dispatch table
  SUBROUTINE InitDispatchTable()
    dispatch(1)%binding => modproc_timetest
    dispatch(2)%binding => modproc_timetest2
  END SUBROUTINE InitDispatchTable
  SUBROUTINE modproc_timetest2(ap, bp, cp, res)
    REAL(rk), INTENT(IN) :: ap, bp, cp
    REAL(rk), INTENT(OUT) :: res
    res = ap * bp * cp
  END SUBROUTINE modproc_timetest2
END MODULE SimulatePolyTypes

PROGRAM test
  USE Kinds
  USE module_A_class
  USE module_AA_class
  USE SimulatePolyTypes
  USE TestProcs
  
  IMPLICIT NONE
  
  ! Descriptions of each test.
  CHARACTER(*), PARAMETER :: test_names(12) = [ &
      'direct call of internal procedure       ',  &      ! 1
      'direct call of module procedure         ',  &      ! 2
      'pass binding of non-polymorphic parent  ',  &      ! 3
      'pass binding of non-polymoprhic ext     ',  &      ! 4
      'nopass binding of non-polymorphic parent',  &      ! 5
      'nopass binding of non-polymorphic ext   ',  &      ! 6
      'pass binding of polymorphic parent      ',  &      ! 7
      'nopass binding of polymorphic parent    ',  &      ! 8
      'call through fixed procedure pointer    ',  &      ! 9
      'call through variable procedure pointer ',  &      ! 10
      'simulate poly through proc-ptr component',  &      ! 11
      'simulate poly through dispatch table    ' ]        ! 12
  
  ! Number of times that we run a test.
  INTEGER, PARAMETER :: num_tests = 1000 * SIZE(test_names)
  
  ! Number of iterations.
  INTEGER, PARAMETER :: num_iters = 10000000
  
  ! The numbers that we need to operate on.
  REAL(rk), ALLOCATABLE :: array_a(:), array_b(:), array_c(:)
  REAL(rk) :: res             ! Procedure call result.
  REAL(rk) :: running_sum     ! Running sum of res.
  
  REAL :: t1 , t2             ! Start and end time.
  
  INTEGER :: itest            ! Test index.
  INTEGER :: test_option      ! Chosen test number.
  INTEGER :: i                ! Iteration index.
  
  CHARACTER(*), PARAMETER :: fmt  &
      = "('Test ',A,' called ',I6,' times with average time ',ES10.2)"
  
  ! Accumulated test times.
  REAL :: test_times(SIZE(test_names))
  
  ! Test counts
  INTEGER :: test_counts(SIZE(test_names))
  
  !-----------------------------------------------------------------------------
  ! Test specific objects.
  
  ! Nonpolymorphic parent object.
  TYPE(A) :: nonpoly_A
  ! Nonpolymorphic extension object.
  TYPE(AA) :: nonpoly_AA
  ! Polymorphic parent object.
  CLASS(A), ALLOCATABLE :: poly_A
  ! Procedure pointer that is fixed at compile time.
  PROCEDURE(modproc_timetest), POINTER :: fixed_proc_ptr
  ! Procedure pointer that is unknown at compile time.
  PROCEDURE(modproc_timetest), POINTER :: variable_proc_ptr
  ! Object with procedure pointer component.
  TYPE(SimulateUsingProcPointer) :: sim_proc_ptr
  ! Object that refers to a dispatch table.
  TYPE(SimulateUsingDispatchTable) :: sim_dispatch_table
  
  !*****************************************************************************
  
  CALL RANDOM_SEED
  
  ! Setup arrays to carry out computations on.
  ALLOCATE(array_a(num_iters), array_b(num_iters), array_c(num_iters))
  CALL RANDOM_NUMBER(array_a)
  CALL RANDOM_NUMBER(array_b)
  CALL RANDOM_NUMBER(array_c)
  
  ! Polymorphic object - declared type parent, dynamic type extension.
  ALLOCATE(AA :: poly_A)
  ! Constant procedure pointer
  fixed_proc_ptr => modproc_timetest
  ! Variable procedure pointer.
  CALL RANDOM_NUMBER(res)
  IF (res <= 0.5) THEN
    variable_proc_ptr => modproc_timetest
  ELSE
    variable_proc_ptr => modproc_timetest2
  END IF
  ! Simulate polymorphic object through procedure pointer component.
  sim_proc_ptr%proc_ptr => modproc_timetest
  ! Simulate polymorphic object through dispatch table.
  CALL InitDispatchTable
  sim_dispatch_table%dispatch => dispatch(1)
  
  test_times = 0.0
  running_sum = 0.0_rk
  
  !-----------------------------------------------------------------------------
  
  DO itest = 1, num_tests
    
    ! Which test should we run?
    test_option = 0
    DO WHILE (test_option <= 0 .OR. test_option > SIZE(test_names))
      CALL RANDOM_NUMBER(res)
      test_option = INT(res  * SIZE(test_names)) + 1
    END DO
    
    CALL CPU_TIME(t1)
    
    SELECT CASE (test_option)
    
    !---------------------------------------------------------------------------
    ! Direct call to internal procedure.
     
    CASE (1)
      DO i = 1, num_iters
        CALL timetest(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
      
    !---------------------------------------------------------------------------
    ! Direct call to module procedure.
    
    CASE (2)
      DO i = 1, num_iters
        CALL modproc_timetest(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Call pass binding of non-polymorphic parent object
    
    CASE (3)
      DO i = 1, num_iters
        CALL nonpoly_A%timetest(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Call pass binding of non-polymorphic extension.
    
    CASE (4)
      DO i = 1, num_iters
        CALL nonpoly_AA%timetest(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Call non-pass binding of non-polymorphic parent object.
    
    CASE (5)
      DO i = 1, num_iters
        CALL nonpoly_A%nopass_test(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Call non-pass binding of non-polymorphic extension object.
    
    CASE (6)
      DO i = 1, num_iters
        CALL nonpoly_AA%nopass_test(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
      
    !---------------------------------------------------------------------------
    ! Call pass binding of polymorphic parent object.
    
    CASE (7)
      DO i = 1, num_iters
        CALL poly_A%timetest(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Call nopass binding of polymorphic parent object
    
    CASE (8)
      DO i = 1, num_iters
        CALL poly_A%nopass_test(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Call through fixed procedure pointer.
    
    CASE (9)
      DO i = 1, num_iters
        CALL fixed_proc_ptr(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Call through variable procedure pointer.
    
    CASE (10)
      DO i = 1, num_iters
        CALL variable_proc_ptr(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Simulate poly through proc-ptr component.
    
    CASE (11)
      DO i = 1, num_iters
        CALL sim_proc_ptr%proc_ptr(array_a(i), array_b(i), array_c(i), res)
        running_sum = running_sum + res
      END DO
    
    !---------------------------------------------------------------------------
    ! Simulate poly through dispatch table.
    
    CASE (12)
      DO i = 1, num_iters
        CALL sim_dispatch_table%dispatch%binding( array_a(i), array_b(i),  &
            array_c(i), res )
        running_sum = running_sum + res
      END DO
    
    END SELECT
    
    CALL CPU_TIME(t2)
    test_counts(test_option) = test_counts(test_option) + 1
    test_times(test_option) = test_times(test_option) + t2 - t1
    
  END DO
  
  PRINT *, running_sum
  DO test_option = 1, SIZE(test_names)
    IF (test_counts(test_option) /= 0) THEN
      PRINT fmt, test_names(test_option), test_counts(test_option),  &
          test_times(test_option) / test_counts(test_option)
    END IF
  END DO
  
CONTAINS
  
  SUBROUTINE timetest(ap, bp, cp, res)
      REAL(rk), INTENT(IN) :: ap, bp, cp
      REAL(rk), INTENT(OUT) :: res
      res = ap * bp * cp
  END SUBROUTINE 
  
END PROGRAM
