growing_allocator_mod.F90 Source File

MODULE GROWING_ALLOCATOR_MOD

  USE ISO_C_BINDING, ONLY: C_INT8_T

  PRIVATE
  PUBLIC :: GROWING_ALLOCATION_TYPE
  PUBLIC :: REALLOCATE_GROWING_ALLOCATION, REGISTER_FREE_FUNCTION

  ABSTRACT INTERFACE
    SUBROUTINE FREE_FUNC_PROC(PTR, SZ) BIND(C)
      USE ISO_C_BINDING, ONLY: C_SIZE_T, C_INT8_T
      IMPLICIT NONE
      INTEGER(KIND=C_INT8_T), TARGET :: PTR(:)
      INTEGER(C_SIZE_T), VALUE :: SZ
    END SUBROUTINE
  END INTERFACE

  TYPE FREE_FUNC_TYPE
    PROCEDURE(FREE_FUNC_PROC), POINTER, NOPASS :: FUNC => NULL ()
  END TYPE

  TYPE GROWING_ALLOCATION_TYPE
    INTEGER(KIND=C_INT8_T), POINTER :: PTR(:)
    TYPE(FREE_FUNC_TYPE) :: FREE_FUNCS(10)
    INTEGER :: FREE_FUNCS_SZ
  END TYPE

CONTAINS

  SUBROUTINE REALLOCATE_GROWING_ALLOCATION(ALLOC, SZ)
    USE ISO_C_BINDING, ONLY: C_SIZE_T
    IMPLICIT NONE
    TYPE(GROWING_ALLOCATION_TYPE), INTENT(INOUT) :: ALLOC
    INTEGER(C_SIZE_T) :: SZ
    INTEGER :: I

    ! Deallocate existing pointer
    IF (ASSOCIATED(ALLOC%PTR) .AND. SZ > SIZE(ALLOC%PTR, 1, C_SIZE_T)) THEN
      PRINT *, "WARNING: REALLOCATING GROWING POINTER CAUSING GRAPH REINSTANTIATION"
      DO I = 1, ALLOC%FREE_FUNCS_SZ
        CALL ALLOC%FREE_FUNCS(I)%FUNC(ALLOC%PTR, &
                                      SIZE(ALLOC%PTR, 1, C_SIZE_T))
      ENDDO
      !$ACC EXIT DATA DELETE(ALLOC%PTR)
      DEALLOCATE(ALLOC%PTR)
      NULLIFY(ALLOC%PTR)
    ENDIF

    IF (.NOT. ASSOCIATED(ALLOC%PTR)) THEN
      ALLOCATE(ALLOC%PTR(SZ))
      !$ACC ENTER DATA CREATE(ALLOC%PTR)
      ALLOC%FREE_FUNCS_SZ = 0
    ENDIF
  END SUBROUTINE

  SUBROUTINE REGISTER_FREE_FUNCTION(ALLOC, FREE_FUNC)
    IMPLICIT NONE
    TYPE(GROWING_ALLOCATION_TYPE) :: ALLOC
    PROCEDURE(FREE_FUNC_PROC) :: FREE_FUNC

    INTEGER :: I

    DO I = 1, ALLOC%FREE_FUNCS_SZ
      IF (ASSOCIATED(ALLOC%FREE_FUNCS(I)%FUNC, FREE_FUNC)) &
        RETURN
    ENDDO

    ALLOC%FREE_FUNCS_SZ = ALLOC%FREE_FUNCS_SZ + 1
    IF (ALLOC%FREE_FUNCS_SZ > SIZE(ALLOC%FREE_FUNCS)) THEN
      PRINT *, "TOO MANY FREE FUNCTIONS REGISTERED"
      STOP 4
    ENDIF
    ALLOC%FREE_FUNCS(ALLOC%FREE_FUNCS_SZ)%FUNC => FREE_FUNC
  END SUBROUTINE

  SUBROUTINE REGISTER_FREE_C(ALLOC_C, FREE_FUNC_C) BIND(C, NAME="growing_allocator_register_free_c")
    USE ISO_C_BINDING, ONLY: C_FUNPTR, C_PTR, C_F_PROCPOINTER, C_F_POINTER
    IMPLICIT NONE
    TYPE(C_PTR), VALUE :: ALLOC_C
    TYPE(C_FUNPTR), VALUE :: FREE_FUNC_C

    TYPE(GROWING_ALLOCATION_TYPE), POINTER :: ALLOC
    PROCEDURE(FREE_FUNC_PROC), POINTER :: FREE_FUNC

    CALL C_F_POINTER(ALLOC_C, ALLOC)
    CALL C_F_PROCPOINTER(FREE_FUNC_C, FREE_FUNC)
    CALL REGISTER_FREE_FUNCTION(ALLOC, FREE_FUNC)

  END SUBROUTINE

END MODULE