Merge pull request #29 from pmarguinaud/bound-checking

Run with bound checking

field_RANKSUFF_data_module.fypp

@@ -284,19 +284,22 @@ CONTAINS
   #:endfor
   #:set ind0 = ind0[:-2]
   #:set ind1 = ind1[:-2]
-  ITHIS_STRIDE = LOC (PTR (${ind1}$)) - LOC (PTR (${ind0}$))
   IF (AFTER < ${d}$) THEN
    #:if d == 1
     ISIZE = 1
    #:else
     ISIZE = SIZE(PTR, ${d-1}$)
    #:endif
-    IF (SIZE(PTR, ${d}$) /= 1 .AND. IPREVIOUS_STRIDE * ISIZE /= ITHIS_STRIDE) THEN
-      JDIM = ${d-1}$
-      RETURN
+    IF (SIZE(PTR, ${d}$) /= 1) THEN
+      ITHIS_STRIDE = LOC (PTR (${ind1}$)) - LOC (PTR (${ind0}$))
+      IF (IPREVIOUS_STRIDE * ISIZE /= ITHIS_STRIDE) THEN
+        JDIM = ${d-1}$
+        RETURN
+      ENDIF
     ENDIF
     IPREVIOUS_STRIDE = IPREVIOUS_STRIDE * ISIZE
   ELSE IF (AFTER == ${d}$) THEN
+    ITHIS_STRIDE = LOC (PTR (${ind1}$)) - LOC (PTR (${ind0}$))
     IPREVIOUS_STRIDE = ITHIS_STRIDE
   ENDIF
 

tests/CMakeLists.txt

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

tests/test_bc.F90

@@ -0,0 +1,115 @@
+! (C) Copyright 2022- ECMWF.
+! (C) Copyright 2022- Meteo-France.
+! (C) Copyright 2023- NVIDIA
+!
+! 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_BC
+  USE FIELD_ABORT_MODULE
+  USE FIELD_MODULE
+  USE PARKIND1
+  USE FIELD_FACTORY_MODULE
+  USE FIELD_ACCESS_MODULE
+  use iso_c_binding
+
+  IMPLICIT NONE
+  CLASS(FIELD_4IM), POINTER :: F4 => NULL()
+
+  INTEGER (KIND=JPIM), PARAMETER :: NDIM = 4
+  INTEGER (KIND=JPIM), PARAMETER :: DIMS (NDIM) = [10, 5, 4, 7]
+
+  INTEGER (KIND=JPIM) :: LB (NDIM), UB (NDIM)
+
+  INTEGER (KIND=JPIM), ALLOCATABLE, TARGET :: DATA4 (:,:,:,:)
+
+  INTEGER (KIND=JPIM), POINTER :: Z4(:,:,:,:)
+
+  INTEGER (KIND=JPIM), POINTER :: D4(:,:,:,:)
+  INTEGER (KIND=JPIM), POINTER :: H4(:,:,:,:)
+
+  INTEGER (KIND=JPIM) :: JDIM, I, J
+
+  INTEGER (KIND=JPIM) :: I1, I2, I3, I4
+
+  INTEGER (KIND=JPIM) :: K1, K2, K3, K4
+  INTEGER (KIND=JPIM) :: FUNC1, FUNC2
+
+  FUNC1 (K1, K2, K3, K4) = K1 + 100 * (K2 + 100 * (K3 + 100 * K4))
+  FUNC2 (K1, K2, K3, K4) = K4 + 100 * (K3 + 100 * (K2 + 100 * K1))
+
+  DO JDIM = 1, NDIM
+    DO I = 1, DIMS (JDIM)
+      DO J = I, DIMS (JDIM)
+
+        ALLOCATE (DATA4 (DIMS (1), DIMS (2), DIMS (3), DIMS (4)))
+
+        LB = 1
+        UB = DIMS
+
+        LB (JDIM) = I
+        UB (JDIM) = J
+
+        Z4 (LB (1):, LB (2):, LB (3):, LB (4):) => DATA4 (LB (1):UB (1), LB (2):UB (2), LB (3):UB (3), LB (4):UB (4))
+
+        DO I4 = LBOUND (Z4, 4), UBOUND (Z4, 4)
+          DO I3 = LBOUND (Z4, 3), UBOUND (Z4, 3)
+            DO I2 = LBOUND (Z4, 2), UBOUND (Z4, 2)
+              DO I1 = LBOUND (Z4, 1), UBOUND (Z4, 1)
+                Z4 (I1, I2, I3, I4) = FUNC1 (I1, I2, I3, I4)
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDDO
+
+        CALL FIELD_NEW (F4, DATA=Z4, LBOUNDS=LB)
+
+        D4 => GET_DEVICE_DATA_RDWR (F4)
+
+!$acc serial present (D4)
+        DO I4 = LBOUND (D4, 4), UBOUND (D4, 4)
+          DO I3 = LBOUND (D4, 3), UBOUND (D4, 3)
+            DO I2 = LBOUND (D4, 2), UBOUND (D4, 2)
+              DO I1 = LBOUND (D4, 1), UBOUND (D4, 1)
+                IF (D4 (I1, I2, I3, I4) /= FUNC1 (I1, I2, I3, I4)) THEN
+                  PRINT *, I1, I2, I3, I4
+                  PRINT *, D4 (I1, I2, I3, I4)
+                  PRINT *, FUNC1 (I1, I2, I3, I4)
+                  STOP 1
+                ENDIF
+                D4 (I1, I2, I3, I4) = FUNC2 (I1, I2, I3, I4)
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDDO
+!$acc end serial
+
+        H4 => GET_HOST_DATA_RDWR (F4)
+
+        DO I4 = LBOUND (H4, 4), UBOUND (H4, 4)
+          DO I3 = LBOUND (H4, 3), UBOUND (H4, 3)
+            DO I2 = LBOUND (H4, 2), UBOUND (H4, 2)
+              DO I1 = LBOUND (H4, 1), UBOUND (H4, 1)
+                IF (H4 (I1, I2, I3, I4) /= FUNC2 (I1, I2, I3, I4)) THEN
+                  PRINT *, I1, I2, I3, I4
+                  PRINT *, D4 (I1, I2, I3, I4)
+                  PRINT *, FUNC2 (I1, I2, I3, I4)
+                  STOP 1
+                ENDIF
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDDO
+
+        CALL FIELD_DELETE (F4)
+
+        DEALLOCATE (DATA4)
+
+      ENDDO
+    ENDDO
+  ENDDO
+
+END PROGRAM TEST_BC