Merge pull request #16 from pmarguinaud/field_gang

Field gang

CMakeLists.txt

@@ -90,7 +90,7 @@ if( NOT fiat_FOUND )
   list(APPEND srcs ${ABOR1_PATH} ${OML_PATH} ${PARKIND1_PATH})
 endif()
 
-list(APPEND srcs field_basic_module.F90 field_init_debug_value_module.F90 dev_alloc.c c_malloc.c)
+list(APPEND srcs field_basic_module.F90 field_defaults_module.F90 dev_alloc.c c_malloc.c field_constants_module.F90 field_abort_module.F90)
 
 ## check for CUDA
 include(CheckLanguage)
@@ -117,9 +117,9 @@ endif()
 foreach (SUFF IN ITEMS IM RM RB RD LM)
   string (TOLOWER ${SUFF} suff)
   foreach (RANK RANGE 2 5)
-    foreach (FUNC IN ITEMS "" _gathscat _access _util _array_util)
+    foreach (FUNC IN ITEMS "" _gathscat _access _util _array_util _gang _factory _gather _data)
       add_custom_command (OUTPUT field_${RANK}${suff}${FUNC}_module.F90
-	      COMMAND ${FYPP} -n -DRANK=${RANK} -DSUFF='${SUFF}' ${fypp_defines} -m os -M ${CMAKE_CURRENT_SOURCE_DIR} -m fieldType 
+	      COMMAND ${FYPP} -DRANK=${RANK} -DSUFF='${SUFF}' ${fypp_defines} -m os -M ${CMAKE_CURRENT_SOURCE_DIR} -m fieldType 
         ${CMAKE_CURRENT_SOURCE_DIR}/field_RANKSUFF${FUNC}_module.fypp > field_${RANK}${suff}${FUNC}_module.F90
         DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/field_RANKSUFF${FUNC}_module.fypp
         VERBATIM)
@@ -129,11 +129,10 @@ foreach (SUFF IN ITEMS IM RM RB RD LM)
   endforeach ()
 endforeach ()
 
-foreach (SRC IN ITEMS dev_alloc_module field_factory_module field_access_module 
-         field_array_module field_module field_gathscat_module field_util_module
-         field_array_util_module host_alloc_module)
+foreach (SRC IN ITEMS dev_alloc_module field_factory_module field_access_module field_gang_module field_array_module field_module 
+                      field_gathscat_module field_util_module field_array_util_module field_gathscat_type_module host_alloc_module)
   add_custom_command (OUTPUT ${SRC}.F90
-	  COMMAND ${FYPP} -n -m os ${fypp_defines} -M ${CMAKE_CURRENT_SOURCE_DIR} -m fieldType ${CMAKE_CURRENT_SOURCE_DIR}/${SRC}.fypp > ${SRC}.F90
+	  COMMAND ${FYPP} -m os ${fypp_defines} -M ${CMAKE_CURRENT_SOURCE_DIR} -m fieldType ${CMAKE_CURRENT_SOURCE_DIR}/${SRC}.fypp > ${SRC}.F90
     DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${SRC}.fypp
     VERBATIM)
   list(APPEND srcs "${SRC}.F90")

field_RANKSUFF_data_module.fypp

@@ -0,0 +1,123 @@
+#! (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}$_DATA_MODULE
+
+#:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + str (SUFF)])
+
+USE FIELD_CONSTANTS_MODULE
+${fieldType.useParkind1 ()}$
+
+IMPLICIT NONE
+
+CONTAINS
+
+#:for ft in fieldTypeList
+#:set ftn = ft.name
+
+#:for d in range (0, ft.rank+1)
+  SUBROUTINE ${ftn}$_COPY_DIM${d}$_CONTIGUOUS (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+#ifdef _OPENACC
+  USE OPENACC
+#endif
+    ${ft.type}$ :: HST (${ft.shape}$), DEV (${ft.shape}$)
+    LOGICAL,                       INTENT (IN) :: MAP_DEVPTR
+    INTEGER (KIND=JPIM),           INTENT (IN) :: KDIR
+    INTEGER (KIND=JPIM), OPTIONAL, INTENT (IN) :: QUEUE
+    INTEGER (KIND=JPIM) :: ISIZE
+    INTEGER :: ${', '.join (['J'] + list (map (lambda i: 'J' + str (i+1), range (d, ft.rank))))}$
+#ifdef _OPENACC
+    TYPE(C_DEVPTR) :: DEVPTR
+#endif
+
+  #:for e in range (ft.rank, d, -1)
+    ${'  ' * (ft.rank - e)}$DO J${e}$ = LBOUND (HST, ${e}$), UBOUND (HST, ${e}$)
+  #:endfor
+  #:set ar = ', '.join ([':'] * d  + list (map (lambda i: 'J' + str (i+1), range (d, ft.rank))))
+  #:set indent = '  ' * (ft.rank - e)
+#ifdef _OPENACC
+    ${indent}$  IF(MAP_DEVPTR)THEN
+    ${indent}$    DEVPTR = ACC_DEVICEPTR(DEV (${ar}$))
+    ${indent}$  ELSE
+  #:if defined('CUDA')
+  !$acc data deviceptr(DEVPTR, DEV)
+    ${indent}$    DEVPTR = C_DEVLOC(DEV (${ar}$))
+  !$acc end data
+  #:endif
+    ${indent}$  ENDIF
+#endif
+    #:if d == 0
+    ${indent}$  ISIZE = KIND (HST)
+    #:else
+    ${indent}$  ISIZE = KIND (HST) * SIZE (HST (${ar}$))
+    #:endif
+    ${indent}$  IF (KDIR == NH2D) THEN
+#ifdef _OPENACC
+    ${indent}$    IF(PRESENT(QUEUE))THEN
+    ${indent}$      CALL ACC_MEMCPY_TO_DEVICE_ASYNC (DEVPTR , HST (${ar}$), ISIZE, QUEUE)
+    ${indent}$    ELSE
+    ${indent}$      CALL ACC_MEMCPY_TO_DEVICE (DEVPTR , HST (${ar}$), ISIZE)
+    ${indent}$    ENDIF
+#else
+    ${indent}$    DEV (${ar}$) = HST (${ar}$)
+#endif
+    ${indent}$  ELSEIF (KDIR == ND2H) THEN
+#ifdef _OPENACC
+    ${indent}$    IF(PRESENT(QUEUE))THEN
+    ${indent}$      CALL ACC_MEMCPY_FROM_DEVICE_ASYNC (HST (${ar}$), DEVPTR, ISIZE, QUEUE)
+    ${indent}$    ELSE
+    ${indent}$      CALL ACC_MEMCPY_FROM_DEVICE (HST (${ar}$), DEVPTR, ISIZE)
+    ${indent}$    ENDIF
+#else
+    ${indent}$    HST (${ar}$) = DEV (${ar}$)
+#endif
+    ${indent}$  ENDIF
+  #:for e in range (d, ft.rank)
+    ${'  ' * (ft.rank - e - 1)}$ENDDO
+  #:endfor
+    END SUBROUTINE
+
+#:endfor
+
+#:endfor
+
+#:for ft in fieldTypeList
+#:set ftn = ft.name
+  INTEGER (KIND=JPIM) FUNCTION ${ftn}$_GET_LAST_CONTIGUOUS_DIMENSION (PTR) RESULT (JDIM)
+  ${ft.type}$, POINTER :: PTR (${ft.shape}$)
+  INTEGER*8 :: ISTRIDE (${ft.rank}$)
+  INTEGER (KIND=JPIM) :: J, LB(${ft.rank}$)
+
+  LB = LBOUND(PTR)
+  ISTRIDE (1) = KIND (PTR)
+  DO J = 2, ${ft.rank}$
+    ISTRIDE (J) = ISTRIDE (J-1) * SIZE (PTR, J-1)
+  ENDDO
+
+  JDIM = 0
+#:for d in range (1, ft.rank+1)
+  #:set ind0 = ""
+  #:set ind1 = ""
+  #:for i in range(1,ft.rank+1)
+    #:set ind0 = ind0 + "LB({}), ".format(i)
+    #:set ind1 = ind1 + "LB({}){}, ".format(i,"+1"*(i==d))
+  #:endfor
+  #:set ind0 = ind0[:-2]
+  #:set ind1 = ind1[:-2]
+  IF (LOC (PTR (${ind1}$)) - LOC (PTR (${ind0}$)) /= ISTRIDE (${d}$)) THEN
+    RETURN
+  ENDIF
+
+  JDIM = ${d}$
+
+#:endfor
+  END FUNCTION ${ftn}$_GET_LAST_CONTIGUOUS_DIMENSION
+#:endfor
+
+END MODULE FIELD_${RANK}$${SUFF}$_DATA_MODULE

field_RANKSUFF_factory_module.fypp

@@ -0,0 +1,181 @@
+#! (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])
+
+USE FIELD_MODULE
+USE FIELD_GANG_MODULE
+${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 ft.rank > 2
+  MODULE PROCEDURE ${ft.name}$_NEW_GANG_WRAPPER
+  MODULE PROCEDURE ${ft.name}$_NEW_GANG_OWNER
+#: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)
+
+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
+
+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)
+
+FIELD_PTR => FIELD_OWNER
+
+END SUBROUTINE
+
+SUBROUTINE ${ft.name}$_NEW_WRAPPER (FIELD_PTR, LBOUNDS, PERSISTENT, DATA, MAP_DEVPTR)
+
+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
+
+ALLOCATE (FIELD_WRAPPER)
+
+CALL FIELD_WRAPPER%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT, MAP_DEVPTR=MAP_DEVPTR)
+
+FIELD_PTR => FIELD_WRAPPER
+
+END SUBROUTINE
+
+#:if ft.rank > 2
+SUBROUTINE ${ft.name}$_NEW_GANG_WRAPPER (FIELD_PTR, CHILDREN, LBOUNDS, PERSISTENT, DATA)
+
+#: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
+
+TYPE(${ft.name}$_GANG_WRAPPER), POINTER :: FIELD_GANG
+INTEGER (KIND=JPIM) :: JFLD
+
+ALLOCATE (FIELD_GANG)
+
+CALL FIELD_GANG%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT)
+
+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
+
+END SUBROUTINE
+
+SUBROUTINE ${ft.name}$_NEW_GANG_OWNER (FIELD_PTR, CHILDREN, UBOUNDS, LBOUNDS, PERSISTENT, DELAYED, INIT_VALUE)
+
+#: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
+
+END SUBROUTINE
+
+#:endif
+
+SUBROUTINE ${ft.name}$_DELETE (FIELD_PTR)
+
+CLASS(${ft.name}$), POINTER :: FIELD_PTR
+
+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