WIP: Implemented CPU only FIELD_XX_BUFFER utils

CMakeLists.txt

@@ -115,7 +115,7 @@ foreach (SUFF IN ITEMS IM RM RB RD LM)
   endforeach ()
 endforeach ()
 
-foreach (SRC IN ITEMS field_factory_module field_access_module 
+foreach (SRC IN ITEMS field_factory_module field_access_module field_buffer_module
          field_array_module field_module field_gathscat_module field_util_module)
   add_custom_command (OUTPUT ${SRC}.F90
 	  COMMAND ${FYPP} -n -m os -M ${CMAKE_CURRENT_SOURCE_DIR} -m fieldType ${CMAKE_CURRENT_SOURCE_DIR}/${SRC}.fypp > ${SRC}.F90

field_buffer_module.fypp

@@ -0,0 +1,298 @@
+#! (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.
+
+MODULE FIELD_BUFFER_MODULE
+
+#:set fieldTypeList = fieldType.getFieldTypeList(ranks=[3,])
+
+USE FIELD_MODULE
+USE FIELD_FACTORY_MODULE
+USE OML_MOD, ONLY: OML_MY_THREAD 
+${fieldType.useParkind1 ()}$
+
+IMPLICIT NONE
+
+#:for ft in fieldTypeList
+#:set ftn = ft.name + '_BUFFER'
+TYPE ${ftn}$ 
+   CLASS(${ft.name}$), POINTER :: BUFFER => NULL()
+   INTEGER(KIND=JPIM) :: NUM_FIELDS = 0
+   LOGICAL :: CONTIG_FIELDS = .FALSE.
+   TYPE(${f'FIELD_{ft.rank-1}{ft.suffix}'}$_PTR), POINTER, PRIVATE :: FIELDS(:) => NULL()
+
+CONTAINS
+
+   PROCEDURE :: ${ftn}$_INIT_WRAPPER
+   PROCEDURE :: ${ftn}$_INIT_OWNER
+   GENERIC :: INIT => ${ftn}$_INIT_WRAPPER, ${ftn}$_INIT_OWNER
+   PROCEDURE, PRIVATE :: ASSIGN_FIELDS => ${ftn}$_ASSIGN_FIELDS
+   PROCEDURE :: FINAL => ${ftn}$_FINAL
+   PROCEDURE :: GET_VIEW => ${ftn}$_GET_VIEW
+#!   PROCEDURE :: GET_DEVICE_DATA_RDONLY => ${ftn}$_GET_DEVICE_DATA_RDONLY
+#!   PROCEDURE :: GET_DEVICE_DATA_RDWR => ${ftn}$_GET_DEVICE_DATA_RDWR
+   PROCEDURE :: GET_HOST_DATA_RDONLY => ${ftn}$_GET_HOST_DATA_RDONLY
+   PROCEDURE :: GET_HOST_DATA_RDWR => ${ftn}$_GET_HOST_DATA_RDWR
+   PROCEDURE :: SYNC_HOST_RDWR => ${ftn}$_SYNC_HOST_RDWR
+   PROCEDURE :: SYNC_HOST_RDONLY => ${ftn}$_SYNC_HOST_RDONLY
+#!   PROCEDURE :: SYNC_DEVICE_RDWR => ${ftn}$_SYNC_DEVICE_RDWR
+#!   PROCEDURE :: SYNC_DEVICE_RDONLY => ${ftn}$_SYNC_DEVICE_RDONLY
+END TYPE ${ftn}$ 
+
+#:endfor
+
+CONTAINS
+
+#:for ft in fieldTypeList
+#:set ftn = ft.name + '_BUFFER'
+SUBROUTINE ${ftn}$_INIT_WRAPPER(SELF, NUM_FIELDS, FIELDS, DATA, CONTIG_FIELDS, PERSISTENT)
+  CLASS(${ftn}$) :: SELF
+  INTEGER(KIND=JPIM), INTENT(IN) :: NUM_FIELDS
+  TYPE(${f'FIELD_{ft.rank-1}{ft.suffix}'}$_PTR), TARGET, INTENT(INOUT) :: FIELDS(NUM_FIELDS)
+
+  ${ft.type}$, TARGET, INTENT(IN) :: DATA(${ft.shape}$)
+  LOGICAL, INTENT(IN), OPTIONAL :: CONTIG_FIELDS, PERSISTENT
+  INTEGER(KIND=JPIM) :: LBOUNDS(${ft.rank}$)
+  LOGICAL :: LLPERSISTENT
+
+  SELF%NUM_FIELDS = NUM_FIELDS
+  IF(PRESENT(CONTIG_FIELDS)) SELF%CONTIG_FIELDS = CONTIG_FIELDS
+
+  !...Consistency checks
+  IF(SELF%CONTIG_FIELDS)THEN
+     IF(UBOUND(DATA, ${ft.rank}$) /= NUM_FIELDS)THEN
+        CALL ABOR1('${ftn}$_WRAPPER: DIMENSION MISMATCH')
+     ENDIF
+  ELSE
+     IF(UBOUND(DATA, ${ft.rank-1}$) /= NUM_FIELDS)THEN
+        CALL ABOR1('${ftn}$_WRAPPER: DIMENSION MISMATCH')
+     ENDIF
+  ENDIF
+
+  !...Wrapper fields are persistent by default
+  LLPERSISTENT = .TRUE.
+  IF(PRESENT(PERSISTENT)) LLPERSISTENT = PERSISTENT
+
+  IF(.NOT. LLPERSISTENT .AND. SELF%CONTIG_FIELDS)THEN
+      CALL ABOR1('${ftn}$_WRAPPER: Thread-local temporaries must be block-strided')
+  ENDIF
+
+  !...Set lower bounds
+  LBOUNDS = LBOUND(DATA)
+  IF(SELF%CONTIG_FIELDS)THEN
+    LBOUNDS(${ft.rank}$) = 1
+  ELSE
+    LBOUNDS(${ft.rank-1}$) = 1
+  ENDIF
+
+  CALL FIELD_NEW(SELF%BUFFER, DATA=DATA, LBOUNDS=LBOUNDS, PERSISTENT=LLPERSISTENT)
+  CALL SELF%ASSIGN_FIELDS(FIELDS, LLPERSISTENT)
+  SELF%FIELDS => FIELDS
+
+END SUBROUTINE ${ftn}$_INIT_WRAPPER
+
+SUBROUTINE ${ftn}$_INIT_OWNER(SELF, NUM_FIELDS, FIELDS, UBOUNDS, CONTIG_FIELDS, LBOUNDS, PERSISTENT)
+  CLASS(${ftn}$) :: SELF
+  INTEGER(KIND=JPIM), INTENT(IN) :: NUM_FIELDS
+  TYPE(${f'FIELD_{ft.rank-1}{ft.suffix}'}$_PTR), TARGET, INTENT(INOUT) :: FIELDS(NUM_FIELDS)
+
+  INTEGER(KIND=JPIM), INTENT(IN) :: UBOUNDS(${ft.rank}$)
+  INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: LBOUNDS(${ft.rank}$)
+  LOGICAL, INTENT(IN), OPTIONAL :: CONTIG_FIELDS, PERSISTENT
+
+  INTEGER(KIND=JPIM) :: LLBOUNDS(${ft.rank}$)
+  LOGICAL :: LLPERSISTENT
+
+  SELF%NUM_FIELDS = NUM_FIELDS
+  IF(PRESENT(CONTIG_FIELDS)) SELF%CONTIG_FIELDS = CONTIG_FIELDS
+
+  !...Consistency checks
+  IF(SELF%CONTIG_FIELDS)THEN
+     IF(UBOUNDS(${ft.rank}$) /= NUM_FIELDS)THEN
+        CALL ABOR1('${ftn}$_OWNER: DIMENSION MISMATCH')
+     ENDIF
+  ELSE
+     IF(UBOUNDS(${ft.rank-1}$) /= NUM_FIELDS)THEN
+        CALL ABOR1('${ftn}$_OWNER: DIMENSION MISMATCH')
+     ENDIF
+  ENDIF
+
+  !...Owner fields are thread-local by default
+  LLPERSISTENT = .FALSE.
+  IF(PRESENT(PERSISTENT)) LLPERSISTENT = PERSISTENT
+
+  IF(.NOT. LLPERSISTENT .AND. SELF%CONTIG_FIELDS)THEN
+      CALL ABOR1('${ftn}$_OWNER: Thread-local temporaries must be block-strided')
+  ENDIF
+
+  !...Set lower bounds
+  LLBOUNDS(:) =  1
+  IF(PRESENT(LBOUNDS)) LLBOUNDS = LBOUNDS
+  IF(SELF%CONTIG_FIELDS)THEN
+    LLBOUNDS(${ft.rank}$) = 1
+  ELSE
+    LLBOUNDS(${ft.rank-1}$) = 1
+  ENDIF
+
+  CALL FIELD_NEW(SELF%BUFFER, UBOUNDS=UBOUNDS, LBOUNDS=LLBOUNDS, PERSISTENT=LLPERSISTENT)
+  CALL SELF%ASSIGN_FIELDS(FIELDS, LLPERSISTENT)
+  SELF%FIELDS => FIELDS
+
+END SUBROUTINE ${ftn}$_INIT_OWNER
+
+SUBROUTINE ${ftn}$_ASSIGN_FIELDS(SELF, FIELDS, PERSISTENT)
+  CLASS(${ftn}$) :: SELF
+  TYPE(${f'FIELD_{ft.rank-1}{ft.suffix}'}$_PTR), INTENT(INOUT) :: FIELDS(:)
+  LOGICAL, INTENT(IN) :: PERSISTENT
+
+  INTEGER(KIND=JPIM), DIMENSION(${ft.rank-1}$) :: LBOUNDS
+  INTEGER(KIND=JPIM) :: IFIELD
+
+  IF(SELF%CONTIG_FIELDS)THEN
+     #:for r in range(1, ft.rank)
+     LBOUNDS(${r}$) = LBOUND(SELF%BUFFER%PTR, ${r}$)
+     #:endfor
+
+     #:set ar = (',').join([':' for _ in range(0, ft.rank-1)])
+     DO IFIELD=1,SELF%NUM_FIELDS
+        CALL FIELD_NEW(FIELDS(IFIELD)%PTR, DATA=SELF%BUFFER%PTR(${ar}$,IFIELD), LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT)
+     ENDDO
+  ELSE
+     #:for r in range(1, ft.rank-1)
+     LBOUNDS(${r}$) = LBOUND(SELF%BUFFER%PTR, ${r}$)
+     #:endfor
+     LBOUNDS(${ft.rank-1}$) = LBOUND(SELF%BUFFER%PTR, ${ft.rank}$)
+
+     #:set ar = (',').join([':' for _ in range(0, ft.rank-2)])
+     DO IFIELD=1,SELF%NUM_FIELDS
+        CALL FIELD_NEW(FIELDS(IFIELD)%PTR, DATA=SELF%BUFFER%PTR(${ar}$,IFIELD,:), LBOUNDS=LBOUNDS, PERSISTENT=PERSISTENT)
+     ENDDO
+  ENDIF
+
+END SUBROUTINE ${ftn}$_ASSIGN_FIELDS
+
+SUBROUTINE ${ftn}$_GET_HOST_DATA_RDWR(SELF, PPTR, QUEUE, FIELDS)
+    CLASS(${ftn}$),   INTENT(INOUT) :: SELF
+    ${ft.type}$, POINTER,         INTENT(INOUT) :: PPTR(${ft.shape}$)
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN)    :: QUEUE
+    TYPE(${f'FIELD_{ft.rank}{ft.suffix}'}$_VIEW), INTENT(OUT), OPTIONAL :: FIELDS(:)
+    INTEGER(KIND=JPIM) :: IFIELD
+
+    CALL SELF%BUFFER%GET_HOST_DATA_RDWR(PPTR, QUEUE=QUEUE)
+
+    IF(PRESENT(FIELDS))THEN
+       DO IFIELD=1,SELF%NUM_FIELDS
+          CALL SELF%FIELDS(IFIELD)%PTR%GET_HOST_DATA_RDWR(FIELDS(IFIELD)%P)
+       ENDDO
+    ENDIF
+
+END SUBROUTINE ${ftn}$_GET_HOST_DATA_RDWR
+
+SUBROUTINE ${ftn}$_GET_HOST_DATA_RDONLY(SELF, PPTR, QUEUE, FIELDS)
+    CLASS(${ftn}$),   INTENT(INOUT) :: SELF
+    ${ft.type}$, POINTER,         INTENT(INOUT) :: PPTR(${ft.shape}$)
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN)    :: QUEUE
+    TYPE(${f'FIELD_{ft.rank}{ft.suffix}'}$_VIEW), INTENT(OUT), OPTIONAL :: FIELDS(:)
+    INTEGER(KIND=JPIM) :: IFIELD
+
+    CALL SELF%BUFFER%GET_HOST_DATA_RDONLY(PPTR, QUEUE=QUEUE)
+
+    IF(PRESENT(FIELDS))THEN
+       DO IFIELD=1,SELF%NUM_FIELDS
+          CALL SELF%FIELDS(IFIELD)%PTR%GET_HOST_DATA_RDONLY(FIELDS(IFIELD)%P)
+       ENDDO
+    ENDIF
+
+END SUBROUTINE ${ftn}$_GET_HOST_DATA_RDONLY
+
+SUBROUTINE ${ftn}$_SYNC_HOST_RDWR(SELF, QUEUE)
+    CLASS(${ftn}$),   INTENT(INOUT) :: SELF
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN)    :: QUEUE
+
+    ${ft.type}$, POINTER :: PPTR(${ft.shape}$)
+    ${ft.type}$, POINTER :: FPTR(${','.join([':' for _ in range(0, ft.rank-1)])}$)
+    INTEGER(KIND=JPIM) :: IFIELD
+
+    CALL SELF%BUFFER%GET_HOST_DATA_RDWR(PPTR, QUEUE=QUEUE)
+
+    DO IFIELD=1,SELF%NUM_FIELDS
+       CALL SELF%FIELDS(IFIELD)%PTR%GET_HOST_DATA_RDWR(FPTR)
+    ENDDO
+
+END SUBROUTINE ${ftn}$_SYNC_HOST_RDWR
+
+SUBROUTINE ${ftn}$_SYNC_HOST_RDONLY(SELF, QUEUE)
+    CLASS(${ftn}$),   INTENT(INOUT) :: SELF
+    INTEGER(KIND=JPIM), OPTIONAL, INTENT(IN)    :: QUEUE
+
+    ${ft.type}$, POINTER :: PPTR(${ft.shape}$)
+    ${ft.type}$, POINTER :: FPTR(${','.join([':' for _ in range(0, ft.rank-1)])}$)
+    INTEGER(KIND=JPIM) :: IFIELD
+
+    CALL SELF%BUFFER%GET_HOST_DATA_RDONLY(PPTR, QUEUE=QUEUE)
+
+    DO IFIELD=1,SELF%NUM_FIELDS
+       CALL SELF%FIELDS(IFIELD)%PTR%GET_HOST_DATA_RDONLY(FPTR)
+    ENDDO
+
+END SUBROUTINE ${ftn}$_SYNC_HOST_RDONLY
+
+FUNCTION ${ftn}$_GET_VIEW(SELF, BLOCK_INDEX, FIELDS, ZERO) RESULT(VIEW_PTR)
+  CLASS(${ftn}$) :: SELF
+  ${ft.type}$, POINTER :: VIEW_PTR(${ft.viewShape}$)
+  INTEGER(KIND=JPIM), INTENT(IN) :: BLOCK_INDEX
+  LOGICAL, OPTIONAL,  INTENT(IN) :: ZERO
+  TYPE(${f'FIELD_{ft.rank-1}{ft.suffix}'}$_VIEW), INTENT(OUT), OPTIONAL :: FIELDS(:)
+  INTEGER(KIND=JPIM) :: IDX, IFIELD
+  INTEGER(KIND=JPIM) :: LBOUNDS(${ft.rank}$)
+  INTEGER(KIND=JPIM) :: LLBOUNDS(${ft.rank-1}$)
+
+  IDX = BLOCK_INDEX
+  IF (SELF%BUFFER%THREAD_BUFFER) IDX = OML_MY_THREAD ()
+
+  LBOUNDS=LBOUND(SELF%BUFFER%PTR)
+  IF(SELF%CONTIG_FIELDS)THEN
+    VIEW_PTR(${','.join('LBOUNDS(%d):'%(r+1) for r in range(ft.viewRank))}$) => SELF%BUFFER%PTR(${','.join(':' for _ in range(ft.viewRank-1))}$,IDX,:)
+  ELSE
+    VIEW_PTR(${','.join('LBOUNDS(%d):'%(r+1) for r in range(ft.viewRank))}$) => SELF%BUFFER%PTR(${','.join(':' for _ in range(ft.viewRank))}$,IDX)
+  ENDIF
+
+  IF (PRESENT(ZERO)) THEN
+    IF (ZERO) VIEW_PTR(${ft.viewShape}$) = ${ft.default}$
+  END IF
+
+  IF(PRESENT(FIELDS))THEN
+    DO IFIELD=1,SELF%NUM_FIELDS
+       LLBOUNDS=LBOUND(SELF%FIELDS(IFIELD)%PTR%PTR)
+       FIELDS(IFIELD)%P(${','.join('LLBOUNDS(%d):'%(r+1) for r in range(ft.viewRank-1))}$) => SELF%FIELDS(IFIELD)%PTR%PTR(${','.join(':' for _ in range(ft.viewRank-1))}$,IDX)
+       IF (PRESENT(ZERO)) THEN
+         IF (ZERO) THEN
+           FIELDS(IFIELD)%P(${','.join('LLBOUNDS(%d):'%(r+1) for r in range(ft.viewRank-1))}$) = ${ft.default}$
+         END IF
+       END IF
+    ENDDO
+  ENDIF
+END FUNCTION ${ftn}$_GET_VIEW
+
+SUBROUTINE ${ftn}$_FINAL(SELF)
+  CLASS(${ftn}$) :: SELF
+  INTEGER(KIND=JPIM) :: IFIELD
+
+  DO IFIELD=1,SELF%NUM_FIELDS
+     CALL FIELD_DELETE(SELF%FIELDS(IFIELD)%PTR)
+  ENDDO
+  NULLIFY(SELF%FIELDS)
+
+  CALL FIELD_DELETE(SELF%BUFFER)
+  NULLIFY(SELF%BUFFER)
+
+END SUBROUTINE ${ftn}$_FINAL
+
+#:endfor
+
+END MODULE FIELD_BUFFER_MODULE

tests/CMakeLists.txt

@@ -29,7 +29,10 @@ list(APPEND TEST_FILES
 	final_wrapper_gpu.F90
 	get_stats.F90
 	get_view.F90
+	get_view_field_buffer.F90
 	init_delayed_owner.F90
+    init_final_owner_field_buffer.F90
+    init_final_wrapper_field_buffer.F90
 	init_owner.F90
 	init_owner2.F90
 	init_owner_gpu.F90