field_RANKSUFF_factory_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 FIELD_${RANK}$${SUFF}$_FACTORY_MODULE

#:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + SUFF])

#:for ft in fieldTypeList
USE ${ft.name}$_MODULE
#:if defined('HAVE_GANG')
#:if ft.ganged
USE FIELD_${ft.rank-1}$${SUFF}$_MODULE
USE ${ft.name}$_GANG_MODULE
#:endif
#:endif
#:endfor

${fieldType.useParkind1 ()}$

IMPLICIT NONE

PRIVATE

INTERFACE FIELD_NEW
#:for ft in fieldTypeList
  MODULE PROCEDURE ${ft.name}$_NEW_OWNER
  MODULE PROCEDURE ${ft.name}$_NEW_WRAPPER
#:if defined('HAVE_GANG')
#:if ft.ganged
  MODULE PROCEDURE ${ft.name}$_NEW_GANG_WRAPPER
  MODULE PROCEDURE ${ft.name}$_NEW_GANG_OWNER
#:endif
#:endif
#:endfor
END INTERFACE

PUBLIC :: FIELD_NEW

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

PUBLIC :: FIELD_DELETE

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

PUBLIC :: FIELD_RESIZE

CONTAINS

#:for ft in fieldTypeList
SUBROUTINE ${ft.name}$_NEW_OWNER (FIELD_PTR, UBOUNDS, LBOUNDS, PERSISTENT, DELAYED, INIT_VALUE, PINNED, MAP_DEVPTR, &
&                                 POOLED)

USE FIELD_STATISTICS_MODULE

CLASS(${ft.name}$), POINTER :: FIELD_PTR
TYPE(${ft.name}$_OWNER), POINTER :: FIELD_OWNER
INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS (${ft.rank}$)
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: LBOUNDS (${ft.rank}$)
LOGICAL, OPTIONAL, INTENT(IN) :: PERSISTENT
LOGICAL, OPTIONAL,  INTENT(IN) :: DELAYED
${ft.type}$, OPTIONAL, INTENT(IN) :: INIT_VALUE
LOGICAL, OPTIONAL,  INTENT(IN) :: PINNED
LOGICAL, OPTIONAL,  INTENT(IN) :: MAP_DEVPTR
LOGICAL, OPTIONAL,  INTENT(IN) :: POOLED

ALLOCATE (FIELD_OWNER)

CALL FIELD_OWNER%INIT (LBOUNDS=LBOUNDS, UBOUNDS=UBOUNDS, PERSISTENT=PERSISTENT, DELAYED=DELAYED, &
&                      INIT_VALUE=INIT_VALUE, PINNED=PINNED, MAP_DEVPTR=MAP_DEVPTR, POOLED=POOLED)

FIELD_PTR => FIELD_OWNER

IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_NEW ()

END SUBROUTINE

SUBROUTINE ${ft.name}$_NEW_WRAPPER (FIELD_PTR, LBOUNDS, PERSISTENT, DATA, MAP_DEVPTR, SYNC_ON_FINAL, INITIALIZED)

USE FIELD_STATISTICS_MODULE

CLASS(${ft.name}$), POINTER :: FIELD_PTR
${ft.type}$, TARGET, INTENT (IN) :: DATA (${ft.shape}$)
TYPE(${ft.name}$_WRAPPER), POINTER :: FIELD_WRAPPER
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: LBOUNDS (${ft.rank}$)
LOGICAL, OPTIONAL, INTENT(IN) :: PERSISTENT
LOGICAL, OPTIONAL,  INTENT(IN) :: MAP_DEVPTR
LOGICAL, OPTIONAL,  INTENT(IN) :: SYNC_ON_FINAL
LOGICAL, OPTIONAL,  INTENT(IN) :: INITIALIZED

ALLOCATE (FIELD_WRAPPER)

CALL FIELD_WRAPPER%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT, MAP_DEVPTR=MAP_DEVPTR, &
                       & SYNC_ON_FINAL=SYNC_ON_FINAL, INITIALIZED=INITIALIZED)

FIELD_PTR => FIELD_WRAPPER

IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_NEW ()

END SUBROUTINE

#:if defined('HAVE_GANG')
#:if ft.ganged
SUBROUTINE ${ft.name}$_NEW_GANG_WRAPPER (FIELD_PTR, CHILDREN, LBOUNDS, PERSISTENT, DATA, SYNC_ON_FINAL, INITIALIZED)

USE FIELD_STATISTICS_MODULE

#:set fieldTypeList1 = fieldType.getFieldTypeList (ranks=[ft.rank-1], kinds=[ft.kind])
#:set ft1 = fieldTypeList1[0]

CLASS(${ft.name}$), POINTER :: FIELD_PTR
TYPE(${ft1.name}$_PTR), ALLOCATABLE :: CHILDREN (:)
${ft.type}$, TARGET, INTENT (IN) :: DATA (${ft.shape}$)
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: LBOUNDS (${ft.rank}$)
LOGICAL, OPTIONAL, INTENT(IN) :: PERSISTENT
LOGICAL, OPTIONAL,  INTENT(IN) :: SYNC_ON_FINAL
LOGICAL, OPTIONAL,  INTENT(IN) :: INITIALIZED

TYPE(${ft.name}$_GANG_WRAPPER), POINTER :: FIELD_GANG
INTEGER (KIND=JPIM) :: JFLD

ALLOCATE (FIELD_GANG)

CALL FIELD_GANG%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT, &
                    & SYNC_ON_FINAL=SYNC_ON_FINAL, INITIALIZED=INITIALIZED)

ALLOCATE (CHILDREN (SIZE (FIELD_GANG%CHILDREN)))

FIELD_PTR => FIELD_GANG

DO JFLD = 1, SIZE (CHILDREN)
  CHILDREN(JFLD)%PTR => FIELD_GANG%CHILDREN(JFLD)%PTR
  FIELD_GANG%CHILDREN (JFLD)%PTR%PARENT => FIELD_PTR
ENDDO

IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_NEW ()

END SUBROUTINE

SUBROUTINE ${ft.name}$_NEW_GANG_OWNER (FIELD_PTR, CHILDREN, UBOUNDS, LBOUNDS, PERSISTENT, DELAYED, INIT_VALUE)

USE FIELD_STATISTICS_MODULE

#:set fieldTypeList1 = fieldType.getFieldTypeList (ranks=[ft.rank-1], kinds=[ft.kind])
#:set ft1 = fieldTypeList1[0]

CLASS(${ft.name}$), POINTER :: FIELD_PTR
TYPE(${ft1.name}$_PTR), ALLOCATABLE :: CHILDREN (:)
INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS (${ft.rank}$)
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: LBOUNDS (${ft.rank}$)
LOGICAL, OPTIONAL, INTENT(IN) :: PERSISTENT
LOGICAL, OPTIONAL,  INTENT(IN) :: DELAYED
${ft.type}$, OPTIONAL, INTENT(IN) :: INIT_VALUE

TYPE(${ft.name}$_GANG_OWNER), POINTER :: FIELD_GANG
INTEGER (KIND=JPIM) :: JFLD

ALLOCATE (FIELD_GANG)

CALL FIELD_GANG%INIT (LBOUNDS=LBOUNDS, UBOUNDS=UBOUNDS, PERSISTENT=PERSISTENT, DELAYED=DELAYED, INIT_VALUE=INIT_VALUE)

ALLOCATE (CHILDREN (SIZE (FIELD_GANG%CHILDREN)))

FIELD_PTR => FIELD_GANG

DO JFLD = 1, SIZE (CHILDREN)
  CHILDREN(JFLD)%PTR => FIELD_GANG%CHILDREN(JFLD)%PTR
  FIELD_GANG%CHILDREN (JFLD)%PTR%PARENT => FIELD_PTR
ENDDO

IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_NEW ()

END SUBROUTINE

#:endif
#:endif

SUBROUTINE ${ft.name}$_DELETE (FIELD_PTR)

USE FIELD_STATISTICS_MODULE

CLASS(${ft.name}$), POINTER :: FIELD_PTR

IF(.NOT. ASSOCIATED(FIELD_PTR)) RETURN

IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_DELETE ()

CALL FIELD_PTR%FINAL ()
DEALLOCATE (FIELD_PTR)
NULLIFY (FIELD_PTR)

END SUBROUTINE

SUBROUTINE ${ft.name}$_RESIZE (FIELD_PTR, UBOUNDS, LBOUNDS, PERSISTENT)

CLASS(${ft.name}$), POINTER :: FIELD_PTR
INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS (${ft.rank}$)
INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: LBOUNDS (${ft.rank}$)
LOGICAL, OPTIONAL, INTENT(IN) :: PERSISTENT

IF (.NOT. ASSOCIATED(FIELD_PTR)) THEN
    CALL FIELD_NEW (FIELD_PTR, UBOUNDS, LBOUNDS, PERSISTENT)
ELSE
    CALL FIELD_PTR%RESIZE (LBOUNDS=LBOUNDS, UBOUNDS=UBOUNDS, PERSISTENT=PERSISTENT)
END IF
END SUBROUTINE ${ft.name}$_RESIZE

#:endfor

END MODULE