Pull back data to legacy structures on device

field_RANKSUFF_util_module.fypp

@@ -18,11 +18,11 @@ ${fieldType.useParkind1 ()}$
 
 IMPLICIT NONE
 
-#:for method in ['LOAD', 'SAVE', 'DIFF', 'COPY', 'WIPE', 'HOST', 'CRC64']
+#:for method in ['LOAD', 'SAVE', 'DIFF', 'COPY', 'WIPE', 'HOST', 'LEGACY', 'CRC64']
 INTERFACE ${method}$
 #:for ft in fieldTypeList
   MODULE PROCEDURE ${method}$_${ft.name}$
-#:if method not in ['DIFF', 'CRC64']
+#:if method not in ['DIFF', 'CRC64', 'LEGACY']
   MODULE PROCEDURE ${method}$_${ft.name}$_PTR
 #:if ft.hasView
   MODULE PROCEDURE ${method}$_${ft.name}$_VIEW
@@ -109,6 +109,59 @@ CALL SELF%SYNC_HOST_RDWR ()
 
 END SUBROUTINE 
 
+SUBROUTINE LEGACY_${ft.name}$ (SELF, KADDRL, KADDRU, KDIR)
+
+USE ${ft.name}$_ACCESS_MODULE
+USE FIELD_CONSTANTS_MODULE
+
+CLASS (${ft.name}$), POINTER :: SELF
+INTEGER*8, INTENT (IN) :: KADDRL
+INTEGER*8, INTENT (IN) :: KADDRU
+INTEGER,   INTENT (IN) :: KDIR
+
+${ft.type}$, POINTER :: PTR (${ft.shape}$), DEVPTR (${ft.shape}$)
+INTEGER*8 :: IADDRL
+INTEGER*8 :: IADDRU
+INTEGER (KIND=JPIM) :: ILBOUNDS (${ft.rank}$)
+INTEGER (KIND=JPIM) :: IUBOUNDS (${ft.rank}$)
+
+IF (ASSOCIATED (SELF)) THEN
+
+  CALL SELF%GET_DIMS (LBOUNDS=ILBOUNDS, UBOUNDS=IUBOUNDS)
+
+  PTR => SELF%PTR
+
+  IADDRL = LOC (PTR (${",".join (map (lambda i: "ILBOUNDS(" + str (i) + ")", range (1, ft.rank+1)))}$))
+  IADDRU = LOC (PTR (${",".join (map (lambda i: "IUBOUNDS(" + str (i) + ")", range (1, ft.rank+1)))}$))
+
+  IF ((KADDRL <= IADDRL) .AND. (IADDRU <= KADDRU)) THEN
+
+    IF (KDIR == NF2L) THEN
+      DEVPTR => GET_DEVICE_DATA_RDONLY (SELF)
+      CALL LEGACY_${ft.name}$_ASSIGN (PTR, DEVPTR)
+    ELSEIF (KDIR == NL2F) THEN
+      DEVPTR => GET_DEVICE_DATA_RDWR (SELF)
+      CALL LEGACY_${ft.name}$_ASSIGN (DEVPTR, PTR)
+    ENDIF
+
+  ENDIF
+
+ENDIF
+
+CONTAINS
+
+SUBROUTINE LEGACY_${ft.name}$_ASSIGN (PTR_RHS, PTR_LHS)
+
+${ft.type}$ :: PTR_RHS (${ft.shape}$), PTR_LHS (${ft.shape}$)
+
+!$acc kernels present (PTR_RHS, PTR_LHS)
+PTR_RHS = PTR_LHS
+!$acc end kernels
+
+END SUBROUTINE
+
+END SUBROUTINE 
+
 #:if ft.hasView
 
 SUBROUTINE LOAD_${ft.name}$_VIEW (KLUN, YD)

field_constants_module.F90

@@ -20,5 +20,6 @@ MODULE FIELD_CONSTANTS_MODULE
 INTEGER (KIND=JPIM), PARAMETER :: NH2D = 1, ND2H = 2
 INTEGER (KIND=JPIM), PARAMETER :: NRD = INT(B'00000001', KIND=JPIM)
 INTEGER (KIND=JPIM), PARAMETER :: NWR = INT(B'00000010', KIND=JPIM)
+INTEGER (KIND=JPIM), PARAMETER :: NF2L = 1, NL2F = 2
 
 END MODULE 

field_util_module.fypp

@@ -18,9 +18,9 @@ MODULE FIELD_UTIL_MODULE
 
 #:for fta, ftb in zip (ftlTA, ftlRB)
 USE ${fta.name}$_UTIL_MODULE, ONLY : &
-#:for method in ['LOAD', 'SAVE', 'DIFF', 'COPY', 'WIPE', 'HOST', 'CRC64']
+#:for method in ['LOAD', 'SAVE', 'DIFF', 'COPY', 'WIPE', 'HOST', 'LEGACY', 'CRC64']
       & ${method}$_${ftb.name}$ => ${method}$_${fta.name}$,  ${method}$_${fta.name}$, ${method}$,      &
-#:if method not in ['DIFF', 'CRC64']
+#:if method not in ['DIFF', 'CRC64', 'LEGACY']
       & ${method}$_${ftb.name}$_PTR  => ${method}$_${fta.name}$_PTR,   ${method}$_${fta.name}$_PTR,    &
 #:if fta.hasView
       & ${method}$_${ftb.name}$_VIEW => ${method}$_${fta.name}$_VIEW,  ${method}$_${fta.name}$_VIEW,   &

tests/CMakeLists.txt

@@ -25,6 +25,7 @@ target_compile_definitions( main.x PRIVATE $<${HAVE_CUDA}:_CUDA> )
 
 ## Unit tests
 list(APPEND TEST_FILES
+        test_legacy.F90
         test_field_array.F90
         gather_scatter_lastdim.F90
         reshuffle_lastdim.F90

tests/test_legacy.F90

@@ -0,0 +1,124 @@
+! (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_LEGACY
+
+USE FIELD_MODULE
+USE FIELD_FACTORY_MODULE
+USE FIELD_ACCESS_MODULE
+USE FIELD_ABORT_MODULE
+USE FIELD_CONSTANTS_MODULE
+USE FIELD_UTIL_MODULE, ONLY : LEGACY, LEGACY_FIELD_3RD
+
+USE PARKIND1
+
+IMPLICIT NONE
+
+CLASS(FIELD_3RB), POINTER :: FU, FV, FT
+
+REAL(KIND=JPRB), ALLOCATABLE :: GMV (:,:,:,:)
+
+REAL(KIND=JPRB), POINTER :: U (:,:,:), V (:,:,:), T (:,:,:)
+
+INTEGER, PARAMETER :: NFLEVG = 5, NPROMA = 32, NGPBLKS = 4, NDIM = 3
+INTEGER, PARAMETER :: IU = 1, IV = 2, IT = 3
+
+INTEGER*8 :: IADDRL, IADDRU
+
+INTEGER :: JLON, JLEV, JBLK
+INTEGER :: IERR
+
+ALLOCATE (GMV (NPROMA, NFLEVG, NDIM, NGPBLKS))
+
+GMV = 0._JPRB
+
+CALL FIELD_NEW (FU, DATA=GMV (:,:,IU,:))
+CALL FIELD_NEW (FV, DATA=GMV (:,:,IV,:))
+CALL FIELD_NEW (FT, DATA=GMV (:,:,IT,:))
+
+! All fields on the device
+
+U => GET_DEVICE_DATA_RDWR (FU)
+V => GET_DEVICE_DATA_RDONLY (FV)
+T => GET_DEVICE_DATA_RDONLY (FT)
+
+!$acc kernels present (U)
+U = 1._JPRB
+!$acc end kernels
+
+!$acc enter data create (GMV)
+!$acc update device (GMV)
+
+IADDRL = LOC (GMV (1,1,1,1))
+IADDRU = LOC (GMV(NPROMA,NFLEVG,NDIM,NGPBLKS))
+
+CALL LEGACY_FIELD_3RD (FU, KADDRL=IADDRL, KADDRU=IADDRU, KDIR=NF2L)
+
+IERR = 0
+
+!$acc serial present (GMV) copy (IERR)
+
+DO JBLK = 1, NGPBLKS
+  DO JLEV = 1, NFLEVG  
+    DO JLON = 1, NPROMA
+      IF (GMV (JLON,JLEV,IU,JBLK) /= 1._JPRB) THEN
+        IERR = IERR + 1
+      ENDIF
+      GMV (JLON,JLEV,IV,JBLK) = 2._JPRB
+    ENDDO
+  ENDDO
+ENDDO
+
+!$acc end serial
+
+IF (IERR /= 0) CALL FIELD_ABORT ('VALUE MISMATCH: KDIR=NF2L')
+
+CALL LEGACY_FIELD_3RD (FV, KADDRL=IADDRL, KADDRU=IADDRU, KDIR=NL2F)
+
+U => GET_DEVICE_DATA_RDONLY (FU)
+V => GET_DEVICE_DATA_RDONLY (FV)
+T => GET_DEVICE_DATA_RDONLY (FT)
+
+IERR = 0
+
+!$acc serial present (U, V, T) copy (IERR)
+
+DO JBLK = 1, NGPBLKS
+  DO JLEV = 1, NFLEVG  
+    DO JLON = 1, NPROMA
+
+        IF (U (JLON, JLEV, JBLK) /= 1._JPRB) THEN
+          IERR = IERR + 1
+        ENDIF
+
+        IF (V (JLON, JLEV, JBLK) /= 2._JPRB) THEN
+          IERR = IERR + 1
+        ENDIF
+
+        IF (T (JLON, JLEV, JBLK) /= 0._JPRB) THEN
+          IERR = IERR + 1
+        ENDIF
+
+    ENDDO
+  ENDDO
+ENDDO
+
+!$acc end serial
+
+IF (IERR /= 0) CALL FIELD_ABORT ('VALUE MISMATCH: KDIR=NL2F')
+
+!$acc exit data delete (GMV)
+
+CALL FIELD_DELETE (FT)
+CALL FIELD_DELETE (FV)
+CALL FIELD_DELETE (FU)
+
+DEALLOCATE (GMV)
+
+END PROGRAM