Merge pull request #24 from pmarguinaud/naan-copy-data-fix

Resolve COPY function at object creation
ecmwf-ifs · Feb 2, 2024 · 08eaf2e · 08eaf2e
2 parents 55c299b + 9b318a1
commit 08eaf2e
Show file tree

Hide file tree

Showing 2 changed files with 59 additions and 12 deletions.
diff --git a/field_RANKSUFF_data_module.fypp b/field_RANKSUFF_data_module.fypp
@@ -23,38 +23,54 @@ PRIVATE
 #:set ftn = ft.name
 
 PUBLIC :: ${ftn}$_COPY
+PUBLIC :: ${ftn}$_COPY_FUNC
+PUBLIC :: ${ftn}$_COPY_INTF
 
+ABSTRACT INTERFACE
+  SUBROUTINE ${ftn}$_COPY_INTF (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+    IMPORT :: JPIM, ${ft.kind}$
+    ${ft.type}$, POINTER :: HST (${ft.shape}$), DEV (${ft.shape}$)
+    LOGICAL,                       INTENT (IN) :: MAP_DEVPTR
+    INTEGER (KIND=JPIM),           INTENT (IN) :: KDIR
+    INTEGER (KIND=JPIM), OPTIONAL, INTENT (IN) :: QUEUE
+  END SUBROUTINE
+END INTERFACE
 #:endfor
 
 CONTAINS
 
 #:for ft in fieldTypeList
 #:set ftn = ft.name
 
-  SUBROUTINE ${ftn}$_COPY (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+  FUNCTION ${ftn}$_COPY_FUNC (HST, DEV) RESULT (FUNC)
 
     USE FIELD_ABORT_MODULE
 
-    ${ft.type}$, POINTER :: HST (${ft.shape}$), DEV (${ft.shape}$)
-    LOGICAL,                       INTENT (IN) :: MAP_DEVPTR
-    INTEGER (KIND=JPIM),           INTENT (IN) :: KDIR
-    INTEGER (KIND=JPIM), OPTIONAL, INTENT (IN) :: QUEUE
+    PROCEDURE (${ftn}$_COPY_INTF), POINTER :: FUNC 
+
+    ${ft.type}$, POINTER, OPTIONAL :: HST (${ft.shape}$), DEV (${ft.shape}$)
+
     INTEGER :: LAST_CONTIG_DIM
     INTEGER :: NEXT_CONTIG_DIM
 
-    LAST_CONTIG_DIM = ${ftn}$_GET_LAST_CONTIGUOUS_DIMENSION (HST, 0)
-    NEXT_CONTIG_DIM = ${ftn}$_GET_LAST_CONTIGUOUS_DIMENSION (HST, LAST_CONTIG_DIM+1)
+    IF (PRESENT (HST)) THEN
+      LAST_CONTIG_DIM = ${ftn}$_GET_LAST_CONTIGUOUS_DIMENSION (HST, 0)
+      NEXT_CONTIG_DIM = ${ftn}$_GET_LAST_CONTIGUOUS_DIMENSION (HST, LAST_CONTIG_DIM+1)
+    ELSE
+      LAST_CONTIG_DIM = ${ft.rank}$
+      NEXT_CONTIG_DIM = ${ft.rank}$
+    ENDIF
 
     SELECT CASE (LAST_CONTIG_DIM)
 #:if defined('CUDA')
       CASE (${ft.rank}$)
-        CALL ${ftn}$_COPY_DIM${ft.rank}$_CONTIGUOUS (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+        FUNC => ${ftn}$_COPY_DIM${ft.rank}$_CONTIGUOUS 
 #:for d1 in range (ft.rank)
       CASE (${d1}$)
         SELECT CASE (NEXT_CONTIG_DIM)
           #:for d2 in range (d1+1, ft.rank+1)
           CASE (${d2}$)
-            CALL ${ftn}$_COPY_2D_DIM${d1}$_${d2}$_CONTIGUOUS (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+            FUNC => ${ftn}$_COPY_2D_DIM${d1}$_${d2}$_CONTIGUOUS 
           #:endfor
           CASE DEFAULT
             CALL FIELD_ABORT ('INTERNAL ERROR: UNEXPECTED NEXT_CONTIG_DIM')
@@ -63,13 +79,30 @@ CONTAINS
 #:else
 #:for d in range (ft.rank + 1)
       CASE (${d}$)
-        CALL ${ftn}$_COPY_DIM${d}$_CONTIGUOUS (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+        FUNC => ${ftn}$_COPY_DIM${d}$_CONTIGUOUS 
 #:endfor
 #:endif
       CASE DEFAULT
         CALL FIELD_ABORT ('INTERNAL ERROR: UNEXPECTED LAST_CONTIG_DIM')
     END SELECT
 
+  END FUNCTION
+
+  SUBROUTINE ${ftn}$_COPY (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+
+    USE FIELD_ABORT_MODULE
+
+    ${ft.type}$, POINTER :: HST (${ft.shape}$), DEV (${ft.shape}$)
+    LOGICAL,                       INTENT (IN) :: MAP_DEVPTR
+    INTEGER (KIND=JPIM),           INTENT (IN) :: KDIR
+    INTEGER (KIND=JPIM), OPTIONAL, INTENT (IN) :: QUEUE
+
+    PROCEDURE (${ftn}$_COPY_INTF), POINTER :: FUNC 
+
+    FUNC => ${ftn}$_COPY_FUNC (HST, DEV) 
+
+    CALL FUNC (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+
   END SUBROUTINE
 
 #:for d in range (0, ft.rank+1)

diff --git a/field_RANKSUFF_module.fypp b/field_RANKSUFF_module.fypp
@@ -27,6 +27,11 @@ USE OPENACC
 #endif
 ${fieldType.useParkind1 ()}$
 
+#:for ft in fieldTypeList
+#:set ftn = ft.name
+USE FIELD_${RANK}$${SUFF}$_DATA_MODULE, ONLY : ${ftn}$_COPY_INTF
+#:endfor
+
 IMPLICIT NONE
 
 PRIVATE
@@ -36,6 +41,7 @@ PRIVATE
 TYPE, ABSTRACT, EXTENDS (FIELD_BASIC) :: ${ftn}$
   ${ft.type}$, POINTER :: PTR(${ft.shape}$) => NULL()
   ${ft.type}$, POINTER, CONTIGUOUS :: DEVPTR(${ft.shape}$) => NULL()
+  PROCEDURE (${ftn}$_COPY_INTF), POINTER, NOPASS :: COPY_FUNC => NULL ()
 CONTAINS
 
   PROCEDURE :: FINAL => ${ftn}$_FINAL
@@ -137,6 +143,7 @@ CONTAINS
 #:set ftn = ft.name
   SUBROUTINE ${ftn}$_WRAPPER_INIT(SELF, DATA, PERSISTENT, LBOUNDS, MAP_DEVPTR)
     USE FIELD_ABORT_MODULE
+    USE ${ftn}$_DATA_MODULE, ONLY : ${ftn}$_COPY_FUNC
 
     ! Create FIELD object by wrapping existing data
     CLASS(${ftn}$_WRAPPER) :: SELF
@@ -173,10 +180,13 @@ CONTAINS
       ENDIF
     ENDIF
 
+    SELF%COPY_FUNC => ${ftn}$_COPY_FUNC (SELF%PTR, SELF%DEVPTR)
+
   END SUBROUTINE ${ftn}$_WRAPPER_INIT
 
   SUBROUTINE ${ftn}$_OWNER_INIT (SELF, LBOUNDS, UBOUNDS, PERSISTENT, DELAYED, INIT_VALUE, PINNED, MAP_DEVPTR)
     USE FIELD_ABORT_MODULE 
+    USE ${ftn}$_DATA_MODULE, ONLY : ${ftn}$_COPY_FUNC
 
     CLASS(${ftn}$_OWNER) :: SELF
     INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(${ft.rank}$)
@@ -245,6 +255,9 @@ CONTAINS
         CALL SELF%SET_STATUS (NHSTFRESH)
       ENDIF
     ENDIF
+
+    SELF%COPY_FUNC => ${ftn}$_COPY_FUNC ()
+
   END SUBROUTINE ${ftn}$_OWNER_INIT
 
   SUBROUTINE ${ftn}$_CREATE_HOST_DATA (SELF)
@@ -371,15 +384,16 @@ CONTAINS
   END SUBROUTINE ${ftn}$_WIPE_OBJECT
 
   SUBROUTINE ${ftn}$_COPY_DATA (SELF, KDIR, QUEUE)
-  USE ${ftn}$_DATA_MODULE
+
   CLASS(${ftn}$) :: SELF
   INTEGER (KIND=JPIM),           INTENT(IN) :: KDIR
   INTEGER (KIND=JPIM), OPTIONAL, INTENT(IN) :: QUEUE
   REAL :: START, FINISH
 
   CALL CPU_TIME(START)
-  CALL ${ftn}$_COPY (SELF%PTR, SELF%DEVPTR, SELF%MAP_DEVPTR, KDIR, QUEUE)
+  CALL SELF%COPY_FUNC (SELF%PTR, SELF%DEVPTR, SELF%MAP_DEVPTR, KDIR, QUEUE)
   CALL CPU_TIME(FINISH)
+
   IF (KDIR == NH2D) THEN
     CALL SELF%STATS%INC_CPU_TO_GPU_TRANSFER(START, FINISH)
   ELSE IF (KDIR == ND2H) THEN