Merge pull request #6 from dareg/field_resize

Field resize

Readme.md

@@ -261,6 +261,7 @@ option).
 For field api type:
 ```
 SUBROUTINE FIELD_NEW(SELF, ...)
+SUBROUTINE FIELD_RESIZE(SELF, ...)
 SUBROUTINE FIELD_DELETE(SELF)
 SUBROUTINE DELETE_DEVICE
 FUNCTION GET_VIEW(SELF, BLOCK_INDEX, ZERO) RESULT(VIEW_PTR)
@@ -274,6 +275,7 @@ SUBROUTINE SYNC_DEVICE_RDWR (SELF, QUEUE)
 SUBROUTINE SYNC_DEVICE_RDONLY (SELF, QUEUE)
 SUBROUTINE COPY_OBJECT (SELF, LDCREATED)
 SUBROUTINE WIPE_OBJECT (SELF, LDDELETED)
+SUBROUTINE GET_DIMS (SELF, LBOUNDS, UBOUNDS)
 ```
 
 Utils:

field_RANKSUFF_module.fypp

@@ -11,7 +11,7 @@ MODULE FIELD_${RANK}$${SUFF}$_MODULE
 
 #:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + str (SUFF)])
 
-USE OML_MOD, ONLY: OML_MAX_THREADS , OML_MY_THREAD 
+USE OML_MOD, ONLY: OML_MAX_THREADS , OML_MY_THREAD
 USE IEEE_ARITHMETIC, ONLY: IEEE_SIGNALING_NAN
 USE DEV_ALLOC_MODULE
 USE FIELD_BASIC_MODULE
@@ -52,6 +52,8 @@ CONTAINS
   PROCEDURE :: SYNC_DEVICE_RDONLY => ${ftn}$_SYNC_DEVICE_RDONLY
   PROCEDURE :: COPY_OBJECT => ${ftn}$_COPY_OBJECT
   PROCEDURE :: WIPE_OBJECT => ${ftn}$_WIPE_OBJECT
+  PROCEDURE(GET_DIMS), DEFERRED :: GET_DIMS
+  PROCEDURE(RESIZE), DEFERRED :: RESIZE
 
   PROCEDURE, PRIVATE :: GET_DEVICE_DATA => ${ftn}$_GET_DEVICE_DATA
   PROCEDURE, PRIVATE :: GET_HOST_DATA => ${ftn}$_GET_HOST_DATA
@@ -61,12 +63,32 @@ CONTAINS
   PROCEDURE, PRIVATE :: CREATE_DEVICE_DATA => ${ftn}$_CREATE_DEVICE_DATA
 END TYPE ${ftn}$
 
+ABSTRACT INTERFACE
+  SUBROUTINE GET_DIMS(SELF, LBOUNDS, UBOUNDS)
+    ${fieldType.useParkind1 ()}$
+    IMPORT ::  ${ftn}$
+    CLASS(${ftn}$),               INTENT(IN) :: SELF
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(OUT) :: LBOUNDS(${ft.rank}$)
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(OUT) :: UBOUNDS(${ft.rank}$)
+  END SUBROUTINE GET_DIMS
+  SUBROUTINE RESIZE (SELF, UBOUNDS, LBOUNDS, PERSISTENT)
+    ${fieldType.useParkind1 ()}$
+    IMPORT ::  ${ftn}$
+    CLASS(${ftn}$),               INTENT(IN) :: SELF
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: UBOUNDS(${ft.rank}$)
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: LBOUNDS(${ft.rank}$)
+    LOGICAL, OPTIONAL,            INTENT(IN) :: PERSISTENT
+  END SUBROUTINE RESIZE
+END INTERFACE
+
 PUBLIC :: ${ftn}$
 
 TYPE, EXTENDS(${ftn}$) :: ${ftn}$_WRAPPER
 CONTAINS
   PROCEDURE :: INIT => ${ftn}$_WRAP
   PROCEDURE :: FINAL => ${ftn}$_WRAPPER_FINAL
+  PROCEDURE :: GET_DIMS => ${ftn}$_WRAPPER_GET_DIMS
+  PROCEDURE :: RESIZE => ${ftn}$_WRAPPER_RESIZE
 END TYPE ${ftn}$_WRAPPER
 
 PUBLIC :: ${ftn}$_WRAPPER
@@ -81,6 +103,8 @@ CONTAINS
   PROCEDURE, PRIVATE :: ALLOCATE => ${ftn}$_ALLOCATE
   PROCEDURE, PRIVATE :: GET_HOST_DATA => ${ftn}$_OWNER_GET_HOST_DATA
   PROCEDURE, PRIVATE :: GET_DEVICE_DATA => ${ftn}$_OWNER_GET_DEVICE_DATA
+  PROCEDURE :: GET_DIMS => ${ftn}$_OWNER_GET_DIMS
+  PROCEDURE :: RESIZE => ${ftn}$_OWNER_RESIZE
 END TYPE ${ftn}$_OWNER
 
 PUBLIC :: ${ftn}$_OWNER
@@ -529,6 +553,54 @@ CONTAINS
 
   END SUBROUTINE ${ftn}$_SYNC_DEVICE_RDWR
 
+  SUBROUTINE ${ftn}$_WRAPPER_GET_DIMS (SELF, LBOUNDS, UBOUNDS)
+    CLASS(${ftn}$_WRAPPER),       INTENT(IN) :: SELF
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(OUT) :: LBOUNDS(${ft.rank}$)
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(OUT) :: UBOUNDS(${ft.rank}$)
+    IF(PRESENT(LBOUNDS))THEN
+      LBOUNDS=LBOUND(SELF%PTR)
+    ENDIF
+    IF(PRESENT(UBOUNDS))THEN
+      UBOUNDS=UBOUND(SELF%PTR)
+    ENDIF
+  END SUBROUTINE ${ftn}$_WRAPPER_GET_DIMS
+
+  SUBROUTINE ${ftn}$_OWNER_GET_DIMS (SELF, LBOUNDS, UBOUNDS)
+    CLASS(${ftn}$_OWNER),         INTENT(IN) :: SELF
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(OUT) :: LBOUNDS(${ft.rank}$)
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(OUT) :: UBOUNDS(${ft.rank}$)
+    IF(PRESENT(LBOUNDS))THEN
+      LBOUNDS=SELF%LBOUNDS
+    ENDIF
+    IF(PRESENT(UBOUNDS))THEN
+      UBOUNDS=SELF%UBOUNDS
+    ENDIF
+  END SUBROUTINE ${ftn}$_OWNER_GET_DIMS
+
+  SUBROUTINE ${ftn}$_WRAPPER_RESIZE (SELF, UBOUNDS, LBOUNDS, PERSISTENT)
+    CLASS(${ftn}$_WRAPPER),       INTENT(IN) :: SELF
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: UBOUNDS(${ft.rank}$)
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: LBOUNDS(${ft.rank}$)
+    LOGICAL, OPTIONAL,            INTENT(IN) :: PERSISTENT
+    CALL ABOR1("RESIZE NOT IMPLMENTED FOR WRAPPER")
+  END SUBROUTINE ${ftn}$_WRAPPER_RESIZE
+
+  SUBROUTINE ${ftn}$_OWNER_RESIZE (SELF, UBOUNDS, LBOUNDS, PERSISTENT)
+    CLASS(${ftn}$_OWNER),         INTENT(IN) :: SELF
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: UBOUNDS(${ft.rank}$)
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN) :: LBOUNDS(${ft.rank}$)
+    LOGICAL, OPTIONAL,            INTENT(IN) :: PERSISTENT
+
+    LOGICAL :: DELAYED
+    ${ft.type}$ :: INIT_VALUE
+
+    DELAYED=.NOT. ASSOCIATED(SELF%PTR)
+    INIT_VALUE=SELF%INIT_VALUE
+
+    CALL SELF%FINAL
+    CALL SELF%INIT(UBOUNDS=UBOUNDS, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT, DELAYED=DELAYED, INIT_VALUE=INIT_VALUE)
+  END SUBROUTINE ${ftn}$_OWNER_RESIZE
+
 #:endfor
 
 #:for ft in fieldTypeList

field_factory_module.fypp

@@ -35,6 +35,14 @@ 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
@@ -54,7 +62,7 @@ CALL FIELD_OWNER%INIT (LBOUNDS=LBOUNDS, UBOUNDS=UBOUNDS, PERSISTENT=PERSISTENT,
 
 FIELD_PTR => FIELD_OWNER
 
-END SUBROUTINE 
+END SUBROUTINE
 
 SUBROUTINE ${ft.name}$_NEW_WRAPPER (FIELD_PTR, LBOUNDS, PERSISTENT, DATA)
 
@@ -70,7 +78,7 @@ CALL FIELD_WRAPPER%INIT (DATA, LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT)
 
 FIELD_PTR => FIELD_WRAPPER
 
-END SUBROUTINE 
+END SUBROUTINE
 
 SUBROUTINE ${ft.name}$_DELETE (FIELD_PTR)
 
@@ -80,7 +88,21 @@ CALL FIELD_PTR%FINAL ()
 DEALLOCATE (FIELD_PTR)
 NULLIFY (FIELD_PTR)
 
-END SUBROUTINE 
+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
 

tests/CMakeLists.txt

@@ -30,6 +30,7 @@ list(APPEND TEST_FILES
 	final_wrapper.F90
 	final_wrapper_gpu.F90
 	gather_scatter.F90
+	get_dims.F90
 	get_stats.F90
 	get_view.F90
 	get_view_get_device_data.F90
@@ -55,6 +56,8 @@ list(APPEND TEST_FILES
 	no_transfer_get_device.F90
 	no_transfer_get_host.F90
 	pointer_to_owner_wrapper.F90
+	resize_owner.F90
+	resize_owner2.F90
 	sync_device.F90
 	sync_host.F90
 	test_crc64.F90
@@ -69,6 +72,7 @@ set(FAILING_TEST_FILES
 set(ABOR1_TEST_FILES
 	get_view_when_ndevfresh.F90
 	get_view_when_unallocated.F90
+	resize_wrapper.F90
 	)
 
 foreach(TEST_FILE ${TEST_FILES})

tests/get_dims.F90

@@ -0,0 +1,75 @@
+! (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 GET_DIMS
+        !TEST THAT GET DIMS RETURN THE RIGHT VALUES
+
+        USE FIELD_MODULE
+        USE FIELD_FACTORY_MODULE
+        USE PARKIND1
+        USE OML_MOD, ONLY: OML_MAX_THREADS
+        IMPLICIT NONE
+        CLASS(FIELD_2RB), POINTER :: O => NULL()
+        CLASS(FIELD_2RB), POINTER :: W => NULL()
+        REAL(KIND=JPRB) :: D(2:33,2:4)
+        INTEGER :: L(2), U(2)
+
+
+        CALL FIELD_NEW(O, LBOUNDS=[10,5], UBOUNDS=[21,11])
+        CALL O%GET_DIMS(LBOUNDS=L, UBOUNDS=U)
+        IF(L(1)/= 10 .AND. L(2)/=5)THEN
+                WRITE(*,*)"OWNER BAD LOWER BOUNDS"
+                ERROR STOP
+        END IF
+        IF(U(1)/= 21 .AND. U(2) /= 11)THEN
+                WRITE(*,*)"OWNER BAD UPPER BOUNDS"
+                ERROR STOP
+        END IF
+        CALL FIELD_DELETE(O)
+
+
+        CALL FIELD_NEW(O, LBOUNDS=[10,5], UBOUNDS=[21,11], PERSISTENT=.FALSE.)
+        IF(L(1)/= 10 .AND. L(2)/=1)THEN
+                WRITE(*,*)"OWNER BAD LOWER BOUNDS WHEN PERSISTENT"
+                ERROR STOP
+        END IF
+        IF(U(1)/= 21 .AND. U(2) /= OML_MAX_THREADS())THEN
+                WRITE(*,*)"OWNER BAD UPPER BOUNDS WHEN PERSISTENT"
+                ERROR STOP
+        END IF
+        CALL FIELD_DELETE(O)
+
+
+        CALL FIELD_NEW(W, DATA=D)
+        CALL W%GET_DIMS(LBOUNDS=L, UBOUNDS=U)
+        IF(L(1)/= 1 .AND. L(2)/=1)THEN
+                WRITE(*,*)"WRAPPER BAD LOWER BOUNDS"
+                ERROR STOP
+        END IF
+        IF(U(1)/= 32 .AND. U(2) /= 3)THEN
+                WRITE(*,*)"WRAPPER BAD UPPER BOUNDS"
+                ERROR STOP
+        END IF
+        CALL FIELD_DELETE(W)
+
+
+        CALL FIELD_NEW(W, DATA=D, LBOUNDS=[2,2])
+        CALL W%GET_DIMS(LBOUNDS=L, UBOUNDS=U)
+        IF(L(1)/= 2 .AND. L(2)/=2)THEN
+                WRITE(*,*)"WRAPPER BAD LOWER BOUNDS WITH LBOUNDS ARG"
+                ERROR STOP
+        END IF
+        IF(U(1)/= 33 .AND. U(2) /= 4)THEN
+                WRITE(*,*)"WRAPPER BAD UPPER BOUNDS WITH LBOUNDS ARG"
+                ERROR STOP
+        END IF
+        CALL FIELD_DELETE(W)
+
+END PROGRAM GET_DIMS
+

tests/resize_owner.F90

@@ -0,0 +1,43 @@
+! (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 RESIZE_OWNER
+        !TEST IF RESIZING A OWNER IS WORKING
+
+        USE FIELD_MODULE
+        USE FIELD_FACTORY_MODULE
+        USE PARKIND1
+        IMPLICIT NONE
+        CLASS(FIELD_2RB), POINTER :: O => NULL()
+        REAL(KIND=JPRB), POINTER :: PTR(:,:)
+        INTEGER(KIND=JPIM) :: L(2),U(2)
+
+        CALL FIELD_NEW(O, LBOUNDS=[10,1], UBOUNDS=[21,11], PERSISTENT=.TRUE.)
+        CALL O%GET_HOST_DATA_RDWR(PTR)
+        PTR=42
+
+        CALL FIELD_RESIZE(O, UBOUNDS=[100,100], PERSISTENT=.TRUE.)
+        CALL O%GET_HOST_DATA_RDWR(PTR)
+        PTR=7
+
+        CALL O%GET_DIMS(LBOUNDS=L,UBOUNDS=U)
+        IF(.NOT. U(1) == 100)THEN
+                WRITE(*,*)"U(1) != 100"
+                ERROR STOP
+        END IF
+        IF(.NOT. U(2) == 100)THEN
+                WRITE(*,*)"U(2) != 100"
+                ERROR STOP
+        END IF
+        IF (.NOT. ALL(PTR == 7)) THEN
+                WRITE(*,*)"PTR != 7"
+                ERROR STOP
+        END IF 
+        CALL FIELD_DELETE(O)
+END PROGRAM RESIZE_OWNER

tests/resize_owner2.F90

@@ -0,0 +1,43 @@
+! (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 RESIZE_OWNER
+        !TEST IF RESIZING A OWNER IS WORKING WHEN SIZE IS REDUCED
+
+        USE FIELD_MODULE
+        USE FIELD_FACTORY_MODULE
+        USE PARKIND1
+        IMPLICIT NONE
+        CLASS(FIELD_2RB), POINTER :: O => NULL()
+        REAL(KIND=JPRB), POINTER :: PTR(:,:)
+        INTEGER(KIND=JPIM) :: L(2),U(2)
+
+        CALL FIELD_NEW(O, LBOUNDS=[10,1], UBOUNDS=[21,11], PERSISTENT=.TRUE.)
+        CALL O%GET_HOST_DATA_RDWR(PTR)
+        PTR=42
+
+        CALL FIELD_RESIZE(O, UBOUNDS=[1,1], PERSISTENT=.TRUE.)
+        CALL O%GET_HOST_DATA_RDWR(PTR)
+        PTR=7
+
+        CALL O%GET_DIMS(UBOUNDS=U,LBOUNDS=L)
+        IF(.NOT. U(1) == 1)THEN
+                WRITE(*,*)"U(1) != 1"
+                ERROR STOP
+        END IF
+        IF(.NOT. U(2) == 1)THEN
+                WRITE(*,*)"U(2) != 1"
+                ERROR STOP
+        END IF
+        IF (.NOT. ALL(PTR == 7)) THEN
+                WRITE(*,*)"PTR != 7"
+                ERROR STOP
+        END IF 
+        CALL FIELD_DELETE(O)
+END PROGRAM RESIZE_OWNER