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
  PUBLIC :: DESTROY_GROWING_ALLOCATOR

  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)
#ifdef OMPGPU
    USE OMP_LIB, ONLY: OMP_GET_DEFAULT_DEVICE, OMP_TARGET_ALLOC, OMP_TARGET_ASSOCIATE_PTR
#endif
    USE ISO_C_BINDING, ONLY: C_SIZE_T, C_PTR, C_F_POINTER, C_LOC
    USE TPM_GEN,       ONLY: NOUT
    IMPLICIT NONE
    TYPE(GROWING_ALLOCATION_TYPE), INTENT(INOUT) :: ALLOC
    INTEGER(C_SIZE_T), INTENT(IN) :: SZ
#ifdef OMPGPU
    TYPE(C_PTR) :: DEV_PTR
    INTEGER :: DEVICE_NUM, IERR
#endif

    ! Deallocate existing pointer
    IF (ASSOCIATED(ALLOC%PTR) .AND. SZ > SIZE(ALLOC%PTR, 1, C_SIZE_T)) THEN
      WRITE(NOUT,*) "WARNING: REALLOCATING GROWING POINTER CAUSING GRAPH REINSTANTIATION"
      CALL DESTROY_GROWING_ALLOCATOR(ALLOC)
    ENDIF

    IF (.NOT. ASSOCIATED(ALLOC%PTR)) THEN
#ifdef OMPGPU
      DEVICE_NUM = OMP_GET_DEFAULT_DEVICE()
      DEV_PTR = OMP_TARGET_ALLOC(SZ, DEVICE_NUM)
      CALL C_F_POINTER(DEV_PTR, ALLOC%PTR, [SZ])
      IERR = OMP_TARGET_ASSOCIATE_PTR(C_LOC(ALLOC%PTR), DEV_PTR, SZ, 0_C_SIZE_T, DEVICE_NUM)
#endif
#ifdef ACCGPU
      ALLOCATE(ALLOC%PTR(SZ))
      !$ACC ENTER DATA CREATE(ALLOC%PTR)
#endif
      ALLOC%FREE_FUNCS_SZ = 0
    ENDIF
  END SUBROUTINE

  SUBROUTINE REGISTER_FREE_FUNCTION(ALLOC, FREE_FUNC)
    USE ABORT_TRANS_MOD, ONLY: ABORT_TRANS
    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
      CALL ABORT_TRANS("REGISTER_FREE_FUNCTION: ERROR - Too many free functions registered")
    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

  SUBROUTINE DESTROY_GROWING_ALLOCATOR(ALLOC)
#ifdef OMPGPU
    USE OMP_LIB, ONLY: OMP_GET_DEFAULT_DEVICE, OMP_TARGET_FREE
#endif
    USE ISO_C_BINDING, ONLY: C_SIZE_T, C_LOC
    IMPLICIT NONE
    TYPE(GROWING_ALLOCATION_TYPE) :: ALLOC
    INTEGER :: I
#ifdef OMPGPU
    INTEGER :: DEVICE_NUM
#endif

    IF (ASSOCIATED(ALLOC%PTR)) THEN
      DO I = 1, ALLOC%FREE_FUNCS_SZ
        CALL ALLOC%FREE_FUNCS(I)%FUNC(ALLOC%PTR, &
                                      SIZE(ALLOC%PTR, 1, C_SIZE_T))
      ENDDO
#ifdef OMPGPU
      DEVICE_NUM = OMP_GET_DEFAULT_DEVICE()
      CALL OMP_TARGET_FREE(C_LOC(ALLOC%PTR), DEVICE_NUM)
#endif
#ifdef ACCGPU
      !$ACC EXIT DATA DELETE(ALLOC%PTR)
      DEALLOCATE(ALLOC%PTR)
#endif
      NULLIFY(ALLOC%PTR)
    ENDIF
  END SUBROUTINE

END MODULE