MODULE Point_Types
      USE ISO_C_BINDING
      PUBLIC :: Point_2D
      TYPE :: Point_2D
         SEQUENCE
         INTEGER (KIND=C_INT) :: screen = 0
         REAL (KIND=C_FLOAT) :: x = 1.0, y = - 1.0
         INTEGER (KIND=C_ADDRESS) :: next = C_NULL_PTR
      END TYPE Point_2D
END MODULE Point_Types
MODULE TestSubroutines
      USE Precision
      USE ISO_C_BINDING
      USE F2x_Emulation
      IMPLICIT NONE
      PUBLIC
      INTERFACE
         SUBROUTINE Call_TestSubroutine (procedure_pointer, n)
            USE ISO_C_BINDING
            INTEGER (KIND=C_INT), INTENT (IN), VALUE :: n
            INTEGER (KIND=C_ADDRESS), INTENT (IN), TARGET :: procedure_pointer
         END SUBROUTINE
      END INTERFACE
CONTAINS
      SUBROUTINE MyTestSubroutine1 (n)
         INTEGER (KIND=C_INT), INTENT (IN), VALUE :: n
         WRITE (*,*) "Fortran subroutine called with n=", n
      END SUBROUTINE MyTestSubroutine1
      SUBROUTINE MyTestSubroutine2 (n)
         INTEGER (KIND=C_INT), INTENT (IN), VALUE :: n
         WRITE (*,*) "Fortran subroutine called with n^2=", n ** 2
      END SUBROUTINE MyTestSubroutine2
END MODULE TestSubroutines
SUBROUTINE Call_TestSubroutine (procedure_pointer, n)
      USE ISO_C_BINDING
      INTEGER (KIND=C_INT), INTENT (IN), VALUE :: n
      INTERFACE
         SUBROUTINE procedure_pointer (n)
            USE ISO_C_BINDING
            INTEGER (KIND=C_INT), INTENT (IN), VALUE :: n
         END SUBROUTINE
      END INTERFACE
      CALL procedure_pointer (n)
END SUBROUTINE
PROGRAM Test_C_Binding
      USE Precision
      USE ISO_C_BINDING
      USE F2x_Emulation
      IMPLICIT NONE
      WRITE (*,*) "Testing interoperability with C dynamic arrays:"
      CALL TestDynamicArrays ()
      WRITE (*,*)
      WRITE (*,*) "Testing derived datatypes:"
      CALL TestDerivedTypes ()
      WRITE (*,*)
      WRITE (*,*) "Testing array pointer reshaping:"
      CALL TestPointerReshaping ()
      WRITE (*,*)
      WRITE (*,*) "Testing procedure pointers:"
      CALL TestProcedurePointers ()
      WRITE (*,*)
CONTAINS
      SUBROUTINE TestDynamicArrays ()
         INTERFACE
            FUNCTION AllocateTestArray_real_F (n, double_precision) RESULT (c_pointer)
               USE ISO_C_BINDING
               INTEGER (KIND=C_SIZE_T), INTENT (IN), VALUE :: n
               LOGICAL (KIND=C_BOOL), INTENT (IN), VALUE :: double_precision
               INTEGER (KIND=C_ADDRESS) :: c_pointer
            END FUNCTION
         END INTERFACE
         INTERFACE
            FUNCTION AllocateTestArray_real_C (n, double_precision) RESULT (c_pointer)
               USE ISO_C_BINDING
               INTEGER (KIND=C_SIZE_T), INTENT (IN), VALUE :: n
               LOGICAL (KIND=C_BOOL), INTENT (IN), VALUE :: double_precision
               INTEGER (KIND=C_ADDRESS) :: c_pointer
            END FUNCTION
         END INTERFACE
         INTERFACE DeallocateArray_C
            SUBROUTINE free_C (c_pointer)
               USE ISO_C_BINDING
               INTEGER (KIND=C_ADDRESS), INTENT (IN), VALUE :: c_pointer
            END SUBROUTINE free_C
         END INTERFACE DeallocateArray_C
         TYPE :: Contiguous_1D_Matrix
            INTEGER (KIND=i_wp) :: n
            INTEGER (KIND=C_ADDRESS) :: c_pointer
            REAL (KIND=r_wp), DIMENSION (:), ALLOCATABLE :: x
         END TYPE Contiguous_1D_Matrix
         TYPE :: Contiguous_2D_Matrix
            INTEGER (KIND=i_wp) :: n_rows, n_columns
            INTEGER (KIND=C_ADDRESS) :: c_pointer
            REAL (KIND=r_wp), DIMENSION (:, :), ALLOCATABLE :: x
         END TYPE Contiguous_2D_Matrix
         TYPE (Contiguous_1D_Matrix) :: x_1D
         TYPE (Contiguous_2D_Matrix) :: x_2D
         INTEGER (KIND=i_wp) :: n
         REAL (KIND=r_wp), DIMENSION (:), POINTER :: x_vector
         REAL (KIND=r_wp), DIMENSION (:, :), POINTER :: x_matrix
         INTEGER (KIND=C_ADDRESS) :: c_pointer
         INTEGER :: alloc_status
         LOGICAL (KIND=C_BOOL) :: allocate_in_C, double_precision
         WRITE (*,*) "Enter n and allocate_in_C (T or F):"
         READ (*,*) n, allocate_in_C
         double_precision = LOGICAL ((r_wp == r_dp), C_BOOL)
         IF ( .NOT. allocate_in_C) THEN
            c_pointer = AllocateTestArray_real_F (n*n, double_precision)
         ELSE
            c_pointer = AllocateTestArray_real_C (n*n, double_precision)
         END IF
         WRITE (*,*) "Integer value of array address:", c_pointer
         IF ( .NOT. C_ASSOCIATED(c_pointer)) THEN
            WRITE (*,*) "Allocation of C pointer failed!"
            STOP
         END IF
         CALL C_F_POINTER (CPTR=c_pointer, FPTR=x_vector, SHAPE= (/ n**2 /))
         CALL C_F_POINTER (CPTR=c_pointer, FPTR=x_matrix, SHAPE= (/ n, n /))
         CALL AssignArrayPointer (array_pointer=x_matrix, array_target=x_matrix, lower_bounds= (/ 0, 1 /))
         WRITE (*,*) "Elements [7:13] of array pointer x_vector: ", x_vector (7:13)
         WRITE (*,*) "Second row of array pointer x_matrix: ", x_matrix (1, :)
         WRITE (*,*) "Second column of array pointer x_matrix: ", x_matrix (:, 2)
         IF (allocate_in_C) CALL DeallocateArray_C (c_pointer)
         x_1D%n = n
         IF ( .NOT. allocate_in_C) THEN
            x_1D%c_pointer = AllocateTestArray_real_F (x_1D%n, double_precision)
         ELSE
            x_1D%c_pointer = AllocateTestArray_real_C (x_1D%n, double_precision)
         END IF
         CALL C_ALLOCATE (CPTR=x_1D%c_pointer, F_ALLOC=x_1D%x, SHAPE= (/ x_1D%n /), STAT=alloc_status)
         IF (alloc_status /= 0) THEN
            WRITE (*,*) "Allocation of dynamic array failed!"
            STOP
         END IF
         WRITE (*,*) "Allocation status of x_1D%x: ", ALLOCATED (x_1D%x)
         WRITE (*,*) "The elements of the dynamic array x_1D%x:", x_1D%x
         x_2D%n_rows = n
         x_2D%n_columns = n
         IF ( .NOT. allocate_in_C) THEN
            x_2D%c_pointer = AllocateTestArray_real_F (x_2D%n_rows*x_2D%n_columns, double_precision)
         ELSE
            x_2D%c_pointer = AllocateTestArray_real_C (x_2D%n_rows*x_2D%n_columns, double_precision)
         END IF
         CALL C_ALLOCATE (CPTR=x_2D%c_pointer, F_ALLOC=x_2D%x, SHAPE= (/ x_2D%n_rows, x_2D%n_columns /), STAT=alloc_status)
         IF (alloc_status /= 0) THEN
            WRITE (*,*) "Allocation of dynamic array failed!"
            STOP
         END IF
         WRITE (*,*) "Allocation status of x_2D%x: ", ALLOCATED (x_2D%x)
         WRITE (*,*) "Second row of the dynamic array x_2D%x:", x_2D%x(2, :)
         WRITE (*,*) "Second column of the dynamic array x_2D%x:", x_2D%x(:, 2)
         CALL C_DEALLOCATE (x_1D%x)
         IF (allocate_in_C) CALL DeallocateArray_C (x_1D%c_pointer)
         WRITE (*,*) "Allocation status of x_1D%x: ", ALLOCATED (x_1D%x)
         CALL C_DEALLOCATE (x_2D%x)
         IF (allocate_in_C) CALL DeallocateArray_C (x_2D%c_pointer)
         WRITE (*,*) "Allocation status of x_2D%x: ", ALLOCATED (x_2D%x)
      END SUBROUTINE TestDynamicArrays
      SUBROUTINE TestDerivedTypes
         USE Point_Types, ONLY: Point_2D
         INTERFACE
            SUBROUTINE DisplayPoint (point)
               USE ISO_C_BINDING
               USE Point_Types, ONLY: Point_2D
               TYPE (Point_2D), INTENT (IN) :: point
            END SUBROUTINE DisplayPoint
         END INTERFACE
         TYPE (Point_2D), TARGET :: point_1 = Point_2D (2,-2.0, 2.0, C_NULL_PTR), point_2
         point_1%next = C_LOC (point_2%screen)
         CALL DisplayPoint (point_1)
      END SUBROUTINE TestDerivedTypes
      SUBROUTINE TestPointerReshaping ()
         TYPE Datum
            INTEGER (KIND=i_sp) :: time = 0
            REAL (KIND=r_dp) :: temperature = 0.0_r_dp
            LOGICAL (KIND=l_word) :: sunny = .TRUE.
         END TYPE Datum
         INTEGER (KIND=i_wp), PARAMETER :: n_x = 5, n_y = 5
         TYPE (Datum), DIMENSION (n_x*n_y), TARGET :: weather_data
         INTEGER (KIND=i_sp), DIMENSION (:), POINTER :: time_diagonal
         INTEGER (KIND=i_sp), DIMENSION (:, :), POINTER :: time_matrix
         INTEGER :: i_x, i_y
         WRITE (*,*) "The stride between successive sunny fields (in words) is:", C_STRIDE (var1=weather_data(1)%sunny, &
        & var2=weather_data(2)%sunny)
         CALL ReshapeArrayPointer (array_pointer=time_matrix, array_target=weather_data%time, lower_bounds= (/ 0, 0 /), &
        & upper_bounds= (/ (n_x-1), (n_y-1) /))
         time_diagonal => weather_data (1::(n_x+1))%time
         DO i_x = 1, n_x
            DO i_y = 1, n_y
               time_matrix (i_x-1, i_y-1) = i_x * i_y
            END DO
         END DO
         WRITE (*,*) "The first row of the time matrix is:", time_matrix (0, :)
         WRITE (*,*) "The diagonal of the time matrix is:", time_diagonal
      END SUBROUTINE TestPointerReshaping
      SUBROUTINE TestProcedurePointers
         USE TestSubroutines
         INTERFACE
            SUBROUTINE ExternalProcedures (f_subroutine)
               USE ISO_C_BINDING
               INTEGER (KIND=C_ADDRESS), INTENT (IN), VALUE :: f_subroutine
            END SUBROUTINE
         END INTERFACE
         INTERFACE
            FUNCTION AllocateTestArray_real_F (n, double_precision) RESULT (c_pointer)
               USE ISO_C_BINDING
               INTEGER (KIND=C_SIZE_T), INTENT (IN), VALUE :: n
               LOGICAL (KIND=C_BOOL), INTENT (IN), VALUE :: double_precision
               INTEGER (KIND=C_ADDRESS) :: c_pointer
            END FUNCTION
         END INTERFACE
         INTERFACE
            FUNCTION AllocateTestArray_real_C (n, double_precision) RESULT (c_pointer)
               USE ISO_C_BINDING
               INTEGER (KIND=C_SIZE_T), INTENT (IN), VALUE :: n
               LOGICAL (KIND=C_BOOL), INTENT (IN), VALUE :: double_precision
               INTEGER (KIND=C_ADDRESS) :: c_pointer
            END FUNCTION
         END INTERFACE
         TYPE (procedure_pointer) :: ATestSubroutine
         WRITE (*,*) "Integer address of C_ASSOCIATED: ", C_LOC_Function (x=C_ASSOCIATED)
         WRITE (*,*) "Integer address of AllocateTestArray_real_F:", C_LOC_Function (x=AllocateTestArray_real_F)
         WRITE (*,*) "Integer address of AllocateTestArray_real_C:", C_LOC_Function (x=AllocateTestArray_real_C)
         ATestSubroutine%c_pointer = C_LOC_Subroutine (x=MyTestSubroutine1)
         CALL C_F_POINTER (CPTR=ATestSubroutine%c_pointer, FPTR=ATestSubroutine%f_pointer)
         CALL ExternalProcedures (ATestSubroutine%c_pointer)
         WRITE (*,*) "Calling procedure at integer address:", ATestSubroutine%c_pointer, " from Fortran"
         CALL Call_TestSubroutine (ATestSubroutine%f_pointer, 13)
         ATestSubroutine%c_pointer = C_LOC_Subroutine (x=MyTestSubroutine2)
         CALL C_F_POINTER (CPTR=ATestSubroutine%c_pointer, FPTR=ATestSubroutine%f_pointer)
         CALL Call_TestSubroutine (ATestSubroutine%f_pointer, 13)
      END SUBROUTINE TestProcedurePointers
END PROGRAM Test_C_Binding
FUNCTION AllocateTestArray_real_F (n, double_precision) RESULT (c_pointer)
      USE Precision
      USE ISO_C_BINDING
      IMPLICIT NONE
      INTEGER (KIND=C_SIZE_T), INTENT (IN), VALUE :: n
      LOGICAL (KIND=C_BOOL), INTENT (IN), VALUE :: double_precision
      INTEGER (KIND=C_ADDRESS) :: c_pointer
      INTEGER (KIND=i_wp) :: i
      REAL (KIND=r_sp), DIMENSION (:), POINTER :: r_sp_array
      REAL (KIND=r_dp), DIMENSION (:), POINTER :: r_dp_array
      INTEGER :: alloc_stat
      Precision_used: IF (double_precision) THEN
         WRITE (*,*) "Allocating REAL(r_dp) space"
         ALLOCATE (r_dp_array(0:(n-1)), STAT=alloc_stat)
         IF (alloc_stat == 0) THEN
            DO i = 0, n - 1
               r_dp_array (i) = REAL (i, r_dp)
            END DO
            c_pointer = C_LOC (r_dp_array)
         ELSE
            c_pointer = C_NULL_PTR
         END IF
      ELSE Precision_used
         WRITE (*,*) "Allocating REAL(r_sp) space"
         ALLOCATE (r_sp_array(0:(n-1)), STAT=alloc_stat)
         IF (alloc_stat == 0) THEN
            DO i = 0, n - 1
               r_sp_array (i) = REAL (i, r_sp)
            END DO
            c_pointer = C_LOC (r_sp_array)
         ELSE
            c_pointer = C_NULL_PTR
         END IF
      END IF Precision_used
END FUNCTION