Add an option to disable wrapper field synchronization on object destruction

field_RANKSUFF_factory_module.fypp

@@ -72,25 +72,26 @@ FIELD_PTR => FIELD_OWNER
 
 END SUBROUTINE
 
-SUBROUTINE ${ft.name}$_NEW_WRAPPER (FIELD_PTR, LBOUNDS, PERSISTENT, DATA, MAP_DEVPTR)
+SUBROUTINE ${ft.name}$_NEW_WRAPPER (FIELD_PTR, LBOUNDS, PERSISTENT, DATA, MAP_DEVPTR, SYNC_ON_FINAL)
 
 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
 
 ALLOCATE (FIELD_WRAPPER)
 
-CALL FIELD_WRAPPER%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT, MAP_DEVPTR=MAP_DEVPTR)
+CALL FIELD_WRAPPER%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT, MAP_DEVPTR=MAP_DEVPTR, SYNC_ON_FINAL=SYNC_ON_FINAL)
 
 FIELD_PTR => FIELD_WRAPPER
 
 END SUBROUTINE
 
 #:if ft.ganged
-SUBROUTINE ${ft.name}$_NEW_GANG_WRAPPER (FIELD_PTR, CHILDREN, LBOUNDS, PERSISTENT, DATA)
+SUBROUTINE ${ft.name}$_NEW_GANG_WRAPPER (FIELD_PTR, CHILDREN, LBOUNDS, PERSISTENT, DATA, SYNC_ON_FINAL)
 
 #:set fieldTypeList1 = fieldType.getFieldTypeList (ranks=[ft.rank-1], kinds=[ft.kind])
 #:set ft1 = fieldTypeList1[0]
@@ -100,13 +101,14 @@ 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
 
 TYPE(${ft.name}$_GANG_WRAPPER), POINTER :: FIELD_GANG
 INTEGER (KIND=JPIM) :: JFLD
 
 ALLOCATE (FIELD_GANG)
 
-CALL FIELD_GANG%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT)
+CALL FIELD_GANG%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT, SYNC_ON_FINAL=SYNC_ON_FINAL)
 
 ALLOCATE (CHILDREN (SIZE (FIELD_GANG%CHILDREN)))
 

field_RANKSUFF_gang_module.fypp

@@ -114,20 +114,21 @@ CONTAINS
 
 #:endfor
 
-  SUBROUTINE ${ftn}$_GANG_WRAPPER_INIT(SELF, DATA, PERSISTENT, LBOUNDS, MAP_DEVPTR)
+  SUBROUTINE ${ftn}$_GANG_WRAPPER_INIT(SELF, DATA, PERSISTENT, LBOUNDS, MAP_DEVPTR, SYNC_ON_FINAL)
     CLASS(${ftn}$_GANG_WRAPPER) :: SELF
     ${ft.type}$, TARGET, INTENT(IN) :: DATA(${ft.shape}$)
     LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT
     INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(${ft.rank}$)
     LOGICAL, INTENT(IN), OPTIONAL :: MAP_DEVPTR
+    LOGICAL, INTENT(IN), OPTIONAL :: SYNC_ON_FINAL
 
     LOGICAL :: LLPERSISTENT
     INTEGER (KIND=JPIM) :: IFLR, JFLD, NFLD
     INTEGER (KIND=JPIM) :: LLBOUNDS (${ft.rank}$)
     CLASS (${ftn1}$_WRAPPER_HELPER), POINTER :: YLFW
 
 
-    CALL SELF%${ftn}$_WRAPPER%INIT (DATA=DATA, PERSISTENT=PERSISTENT, LBOUNDS=LBOUNDS, MAP_DEVPTR=MAP_DEVPTR)
+    CALL SELF%${ftn}$_WRAPPER%INIT (DATA=DATA, PERSISTENT=PERSISTENT, LBOUNDS=LBOUNDS, MAP_DEVPTR=MAP_DEVPTR, SYNC_ON_FINAL=SYNC_ON_FINAL)
 
     LLBOUNDS = 1
     IF (PRESENT (LBOUNDS)) LLBOUNDS = LBOUNDS
@@ -142,7 +143,7 @@ CONTAINS
 
     DO JFLD = 1, NFLD
       ALLOCATE (YLFW)
-      CALL YLFW%INIT (DATA=DATA(${ar}$, JFLD, :), PERSISTENT=PERSISTENT, LBOUNDS=LLBOUNDS(1:IFLR), MAP_DEVPTR=MAP_DEVPTR)
+      CALL YLFW%INIT (DATA=DATA(${ar}$, JFLD, :), PERSISTENT=PERSISTENT, LBOUNDS=LLBOUNDS(1:IFLR), MAP_DEVPTR=MAP_DEVPTR, SYNC_ON_FINAL=SYNC_ON_FINAL)
       SELF%CHILDREN (JFLD)%PTR => YLFW
       CALL SELF%CHILDREN(JFLD)%PTR%SET_STATUS (SELF%GET_STATUS ())
     ENDDO
@@ -181,7 +182,7 @@ CONTAINS
 
     DO JFLD = 1, NFLD
       ALLOCATE (YLFW)
-      CALL YLFW%INIT (DATA=SELF%PTR (${ar}$, JFLD, :), PERSISTENT=PERSISTENT, LBOUNDS=LLBOUNDS(1:IFLR))
+      CALL YLFW%INIT (DATA=SELF%PTR (${ar}$, JFLD, :), PERSISTENT=PERSISTENT, LBOUNDS=LLBOUNDS(1:IFLR), SYNC_ON_FINAL=.FALSE.)
       SELF%CHILDREN (JFLD)%PTR => YLFW
       CALL SELF%CHILDREN(JFLD)%PTR%SET_STATUS (SELF%GET_STATUS ())
     ENDDO

field_RANKSUFF_module.fypp

@@ -89,6 +89,7 @@ END INTERFACE
 PUBLIC :: ${ftn}$
 
 TYPE, EXTENDS(${ftn}$) :: ${ftn}$_WRAPPER
+  LOGICAL :: SYNC_ON_FINAL = .TRUE.
 CONTAINS
   PROCEDURE :: INIT => ${ftn}$_WRAPPER_INIT
   PROCEDURE :: FINAL => ${ftn}$_WRAPPER_FINAL
@@ -135,15 +136,18 @@ CONTAINS
 
 #:for ft in fieldTypeList
 #:set ftn = ft.name
-  SUBROUTINE ${ftn}$_WRAPPER_INIT(SELF, DATA, PERSISTENT, LBOUNDS, MAP_DEVPTR)
+  SUBROUTINE ${ftn}$_WRAPPER_INIT(SELF, DATA, PERSISTENT, LBOUNDS, MAP_DEVPTR, SYNC_ON_FINAL)
     USE FIELD_ABORT_MODULE
+    USE FIELD_DEFAULTS_MODULE
 
     ! Create FIELD object by wrapping existing data
     CLASS(${ftn}$_WRAPPER) :: SELF
     ${ft.type}$, TARGET, INTENT(IN) :: DATA(${ft.shape}$)
     LOGICAL, INTENT(IN), OPTIONAL :: PERSISTENT
     LOGICAL, INTENT(IN), OPTIONAL :: MAP_DEVPTR
     INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(${ft.rank}$)
+    LOGICAL, INTENT(IN), OPTIONAL :: SYNC_ON_FINAL
+
     LOGICAL :: LLPERSISTENT
 #include "abor1.intfb.h"
 
@@ -158,15 +162,21 @@ CONTAINS
     SELF%THREAD_BUFFER = .NOT. LLPERSISTENT
     CALL SELF%SET_STATUS (NHSTFRESH)
 
+    SELF%MAP_DEVPTR = INIT_MAP_DEVPTR
     IF(PRESENT(MAP_DEVPTR))THEN
       SELF%MAP_DEVPTR = MAP_DEVPTR
     ENDIF
 #:if not defined('CUDA')
     IF(.NOT. SELF%MAP_DEVPTR)THEN
-       CALL FIELD_ABORT ("${ftn}$_OWNER_INIT: CUDA backend needed to disable host-mapped device-pointer")
+       CALL FIELD_ABORT ("${ftn}$_WRAPPER_INIT: CUDA backend needed to disable host-mapped device-pointer")
     ENDIF
 #:endif
 
+    SELF%SYNC_ON_FINAL = INIT_SYNC_ON_FINAL
+    IF (PRESENT (SYNC_ON_FINAL)) THEN
+      SELF%SYNC_ON_FINAL = SYNC_ON_FINAL
+    ENDIF
+
     IF (.NOT. LLPERSISTENT) THEN
       IF (OML_MAX_THREADS () /= SIZE (DATA, ${ft.rank}$)) THEN
         CALL FIELD_ABORT ('${ftn}$_WRAPPER_INIT: DIMENSION MISMATCH')
@@ -202,6 +212,7 @@ CONTAINS
       SELF%PINNED = PINNED
     ENDIF
 
+    SELF%MAP_DEVPTR = INIT_MAP_DEVPTR
     IF(PRESENT(MAP_DEVPTR))THEN
       SELF%MAP_DEVPTR = MAP_DEVPTR
     ENDIF
@@ -307,7 +318,9 @@ CONTAINS
     ! Finalizes field and deallocates owned data
     CLASS(${ftn}$_WRAPPER) :: SELF
     ${ft.type}$, POINTER :: PTR(${ft.shape}$)
-    CALL SELF%GET_HOST_DATA_RDONLY(PTR)
+    IF (SELF%SYNC_ON_FINAL) THEN
+      CALL SELF%GET_HOST_DATA_RDONLY(PTR)
+    ENDIF
     CALL SELF%${ftn}$_FINAL
   END SUBROUTINE ${ftn}$_WRAPPER_FINAL
 

field_defaults_module.F90

@@ -7,4 +7,6 @@ MODULE FIELD_DEFAULTS_MODULE
   INTEGER(KIND=JPIM) :: INIT_DEBUG_VALUE_JPIM = 0_JPIM
   LOGICAL(KIND=JPLM) :: INIT_DEBUG_VALUE_JPLM = .FALSE.
   LOGICAL :: INIT_PINNED_VALUE = .FALSE.
+  LOGICAL :: INIT_SYNC_ON_FINAL = .TRUE.
+  LOGICAL :: INIT_MAP_DEVPTR = .TRUE.
 END MODULE FIELD_DEFAULTS_MODULE

tests/CMakeLists.txt

@@ -25,6 +25,7 @@ target_compile_definitions( main.x PRIVATE $<${HAVE_CUDA}:_CUDA> )
 
 ## Unit tests
 list(APPEND TEST_FILES
+        test_wrappernosynconfinal.F90
         test_field1d.F90
         test_pinned.F90
 	async_host.F90

tests/test_wrappernosynconfinal.F90

@@ -0,0 +1,135 @@
+! (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.
+
+PROGRAM TEST_WRAPPERNOSYNCONFINAL
+
+USE FIELD_MODULE
+USE FIELD_FACTORY_MODULE
+USE FIELD_ACCESS_MODULE
+USE PARKIND1
+USE FIELD_ABORT_MODULE
+IMPLICIT NONE
+
+
+CALL TEST_FIELD
+CALL TEST_GANG
+
+CONTAINS
+
+SUBROUTINE TEST_FIELD
+
+CLASS(FIELD_2RB), POINTER :: W => NULL()
+REAL(KIND=JPRB), ALLOCATABLE :: D(:,:)
+REAL(KIND=JPRB), POINTER :: DD(:,:)
+
+ALLOCATE(D(10,4))
+
+D=7
+
+CALL FIELD_NEW (W, DATA=D, SYNC_ON_FINAL=.FALSE.)
+
+DD => GET_DEVICE_DATA_RDWR (W)
+
+!$acc serial present (DD)
+DD = 22
+!$acc end serial
+
+CALL FIELD_DELETE (W)
+
+IF (ANY (D /= 7)) THEN
+  CALL FIELD_ABORT ('UNEXPECTED VALUES')
+  WRITE (*, *) D
+ENDIF
+
+DEALLOCATE (D)
+
+ALLOCATE(D(10,4))
+
+D=7
+
+CALL FIELD_NEW (W, DATA=D, SYNC_ON_FINAL=.TRUE.)
+
+DD => GET_DEVICE_DATA_RDWR (W)
+
+!$acc serial present (DD)
+DD = 22
+!$acc end serial
+
+CALL FIELD_DELETE (W)
+
+IF (ANY (D /= 22)) THEN
+  CALL FIELD_ABORT ('UNEXPECTED VALUES')
+  WRITE (*, *) D
+ENDIF
+
+END SUBROUTINE
+
+SUBROUTINE TEST_GANG
+
+CLASS(FIELD_4RD), POINTER :: YLF4
+TYPE(FIELD_3RD_PTR), ALLOCATABLE :: YLF3L (:)
+
+REAL (KIND=JPRD), ALLOCATABLE :: ZDATA4 (:,:,:,:)
+REAL (KIND=JPRD), POINTER :: ZD4 (:,:,:,:), ZD3 (:,:,:), ZH4 (:,:,:,:), ZH3 (:,:,:)
+
+ALLOCATE (ZDATA4 (8,2,3,4))
+
+ZDATA4 = 123._JPRD
+
+CALL FIELD_NEW (YLF4, CHILDREN=YLF3L, PERSISTENT=.TRUE., DATA=ZDATA4, SYNC_ON_FINAL=.FALSE.)
+
+ZD4 => GET_DEVICE_DATA_RDWR (YLF4)
+
+!$acc serial present (ZD4)
+ZD4 = 456._JPRD
+!$acc end serial
+
+ZD3 => GET_DEVICE_DATA_RDWR (YLF3L (1)%PTR)
+
+!$acc serial present (ZD3)
+ZD3 = 789._JPRD
+!$acc end serial
+
+DEALLOCATE (YLF3L)
+CALL FIELD_DELETE (YLF4)
+
+IF (ANY (ZDATA4 /= 123._JPRD)) THEN
+  CALL FIELD_ABORT ('UNEXPECTED VALUES')
+  WRITE (*, *) ZDATA4 
+ENDIF
+
+DEALLOCATE (ZDATA4)
+
+
+ALLOCATE (ZDATA4 (8,2,3,4))
+
+ZDATA4 = 123._JPRD
+
+CALL FIELD_NEW (YLF4, CHILDREN=YLF3L, PERSISTENT=.TRUE., DATA=ZDATA4, SYNC_ON_FINAL=.TRUE.)
+
+ZD4 => GET_DEVICE_DATA_RDWR (YLF4)
+
+!$acc serial present (ZD4)
+ZD4 = 456._JPRD
+!$acc end serial
+
+DEALLOCATE (YLF3L)
+CALL FIELD_DELETE (YLF4)
+
+IF (ANY (ZDATA4 /= 456._JPRD)) THEN
+  CALL FIELD_ABORT ('UNEXPECTED VALUES')
+  WRITE (*, *) ZDATA4 
+ENDIF
+
+DEALLOCATE (ZDATA4)
+
+
+END SUBROUTINE
+
+END PROGRAM