dev_alloc_module.fypp

#! (C) Copyright 2022- ECMWF.
#! (C) Copyright 2022- Meteo-France.
#!
#! This software is licensed under the terms of the Apache Licence Version 2.0
#! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
#! In applying this licence, ECMWF does not waive the privileges and immunities
#! granted to it by virtue of its status as an intergovernmental organisation
#! nor does it submit to any jurisdiction.

MODULE DEV_ALLOC_MODULE

#:set fieldTypeList = fieldType.getFieldTypeList ()

${fieldType.useParkind1 ()}$

#:if defined('USE_BUDDY_MALLOC') or defined('CUDA')
USE ISO_C_BINDING
#:endif
#ifdef _OPENACC
USE OPENACC
#endif
#:if defined('CUDA')
USE CUDAFOR
#:endif

IMPLICIT NONE

INTERFACE DEV_ALLOCATE_HST
#:for ft in fieldTypeList
  MODULE PROCEDURE ${ft.name}$_DEV_ALLOCATE_HST
#:endfor
END INTERFACE

#:if defined('USE_BUDDY_MALLOC')
INTERFACE DEV_ALLOCATE_DIM
#:for ft in fieldTypeList
  MODULE PROCEDURE ${ft.name}$_DEV_ALLOCATE_DIM
#:endfor
END INTERFACE
#:endif

INTERFACE DEV_DEALLOCATE
#:for ft in fieldTypeList
  MODULE PROCEDURE ${ft.name}$_DEV_DEALLOCATE
#:endfor
END INTERFACE

#:if defined('USE_BUDDY_MALLOC')
INTERFACE
  SUBROUTINE DEV_MALLOC (SIZ, PTR) BIND (C, NAME='dev_malloc')
    IMPORT :: C_PTR, C_SIZE_T
    INTEGER (C_SIZE_T), VALUE, INTENT(IN) :: SIZ
    TYPE (C_PTR), INTENT(OUT) :: PTR
  END SUBROUTINE
  SUBROUTINE DEV_FREE (PTR) BIND (C, NAME='dev_free')
    IMPORT :: C_PTR
    TYPE (C_PTR), VALUE, INTENT(IN) :: PTR
  END SUBROUTINE
END INTERFACE
#:endif

#:if defined('CUDA')
INTERFACE
  INTEGER FUNCTION CUDA_MALLOC (PTR,SIZ) BIND (C, NAME='cudaMalloc')
    IMPORT :: C_PTR, C_SIZE_T
    INTEGER (C_SIZE_T), VALUE, INTENT(IN) :: SIZ
    TYPE (C_PTR), INTENT(OUT) :: PTR
  END FUNCTION CUDA_MALLOC
  INTEGER FUNCTION CUDA_FREE (PTR) BIND (C, NAME='cudaFree')
    IMPORT :: C_PTR
    TYPE (C_PTR), VALUE, INTENT(IN) :: PTR
  END FUNCTION CUDA_FREE
END INTERFACE
#:endif

CONTAINS


#:for ft in fieldTypeList

#:if defined('USE_BUDDY_MALLOC') or defined('CUDA')

SUBROUTINE ${ft.name}$_DEV_ALLOCATE_HST (DEV, HST, MAP_DEVPTR)

${ft.type}$, POINTER :: DEV(${ft.shape}$)
${ft.type}$, POINTER :: HST(${ft.shape}$)
LOGICAL, INTENT(IN) :: MAP_DEVPTR

INTEGER :: ILBOUNDS (${ft.rank}$)
INTEGER :: IUBOUNDS (${ft.rank}$)

ILBOUNDS = LBOUND (HST)
IUBOUNDS = UBOUND (HST)

CALL ${ft.name}$_DEV_ALLOCATE_DIM (DEV, UBOUNDS=IUBOUNDS, LBOUNDS=ILBOUNDS, MAP_DEVPTR=MAP_DEVPTR)

END SUBROUTINE ${ft.name}$_DEV_ALLOCATE_HST

SUBROUTINE ${ft.name}$_DEV_ALLOCATE_DIM (DEV, UBOUNDS, LBOUNDS, MAP_DEVPTR)

USE FIELD_STATISTICS_MODULE

${ft.type}$, POINTER :: DEV(${ft.shape}$)
INTEGER (KIND=JPIM), INTENT (IN) :: UBOUNDS (${ft.rank}$)
INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: LBOUNDS (${ft.rank}$)
INTEGER (KIND=JPIM) :: ILBOUNDS (${ft.rank}$)
${ft.type}$, POINTER :: TMP(${ft.shape}$)
LOGICAL, INTENT(IN) :: MAP_DEVPTR

TYPE (C_PTR) :: PTR
INTEGER (C_SIZE_T) :: SIZ
#:if defined('CUDA')
INTEGER :: ISTAT
#:endif

ILBOUNDS = 1
IF (PRESENT (LBOUNDS)) ILBOUNDS = LBOUNDS

SIZ = KIND (DEV)
#:for i in range (1, ft.rank+1, 1)
SIZ = SIZ * INT (UBOUNDS(${i}$)-ILBOUNDS(${i}$)+1, C_SIZE_T)
#:endfor

IF(MAP_DEVPTR)THEN
  CALL DEV_MALLOC (SIZ, PTR)
ELSE
#:if defined('CUDA')
  ISTAT = CUDA_MALLOC(PTR, SIZ)
#:endif
ENDIF

CALL C_F_POINTER (PTR, TMP, UBOUNDS-ILBOUNDS+1)
DEV (${ ', '.join (map (lambda i: 'ILBOUNDS (' + str (i) + '):', range (1, ft.rank+1))) }$) => TMP

IF(MAP_DEVPTR)THEN
!$acc enter data create (DEV)
ENDIF

IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_DEVICE_ALLOCATE (SIZE (DEV, KIND=JPIB) * INT (KIND (DEV), KIND=JPIB))

END SUBROUTINE ${ft.name}$_DEV_ALLOCATE_DIM

SUBROUTINE ${ft.name}$_DEV_DEALLOCATE (DEV, MAP_DEVPTR)

USE FIELD_STATISTICS_MODULE

${ft.type}$, POINTER :: DEV(${ft.shape}$)
LOGICAL, INTENT(IN) :: MAP_DEVPTR
TYPE (C_PTR) :: PTR
#:if defined('CUDA')
INTEGER :: ISTAT
#:endif

IF (ASSOCIATED (DEV)) THEN

  IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_DEVICE_DEALLOCATE (SIZE (DEV, KIND=JPIB) * INT (KIND (DEV), KIND=JPIB))

  PTR = C_LOC (DEV (${ ', '.join (map (lambda i: 'LBOUND (DEV, ' + str (i) + ')', range (1, ft.rank+1))) }$))
  
  IF(MAP_DEVPTR)THEN
    CALL DEV_FREE (PTR)
    !$acc exit data delete (DEV)
  ELSE
#:if defined('CUDA')
    ISTAT = CUDA_FREE (PTR)
#:endif
  ENDIF

  NULLIFY (DEV)

ENDIF

END SUBROUTINE ${ft.name}$_DEV_DEALLOCATE

#:else

SUBROUTINE ${ft.name}$_DEV_ALLOCATE_HST (DEV, HST, MAP_DEVPTR)

${ft.type}$, POINTER :: DEV(${ft.shape}$)
${ft.type}$, POINTER :: HST(${ft.shape}$)
LOGICAL, INTENT(IN) :: MAP_DEVPTR

#if __INTEL_COMPILER == 1800 && __INTEL_COMPILER_UPDATE == 5
! Bug with Intel 18.0.5.274
ALLOCATE (DEV (${ ', '.join (map (lambda i: 'LBOUND (HST, ' + str (i) + '):UBOUND (HST,' + str (i) + ')', range (1, ft.rank+1))) }$))
#else
ALLOCATE (DEV, MOLD=HST)
#endif

!$acc enter data create (DEV)

IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_DEVICE_ALLOCATE (SIZE (DEV, KIND=JPIB) * INT (KIND (DEV), KIND=JPIB))

END SUBROUTINE ${ft.name}$_DEV_ALLOCATE_HST

SUBROUTINE ${ft.name}$_DEV_DEALLOCATE (DEV, MAP_DEVPTR)

${ft.type}$, POINTER :: DEV(${ft.shape}$)
LOGICAL, INTENT(IN) :: MAP_DEVPTR

IF (ASSOCIATED (DEV)) THEN

  IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_DEVICE_DEALLOCATE (SIZE (DEV, KIND=JPIB) * INT (KIND (DEV), KIND=JPIB))

  !$acc exit data delete (DEV)
  DEALLOCATE (DEV)
  NULLIFY (DEV)
ENDIF

END SUBROUTINE ${ft.name}$_DEV_DEALLOCATE

#:endif

#:endfor

END MODULE DEV_ALLOC_MODULE