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