adding multi-blk support WIP

dev_alloc_module.fypp

@@ -31,6 +31,12 @@ INTERFACE DEV_ALLOCATE_HST
 #:endfor
 END INTERFACE
 
+INTERFACE DEV_ALLOCATE_BLKS
+#:for ft in fieldTypeList
+  MODULE PROCEDURE ${ft.name}$_DEV_ALLOCATE_BLKS
+#:endfor
+END INTERFACE
+
 #:if defined('USE_BUDDY_MALLOC')
 INTERFACE DEV_ALLOCATE_DIM
 #:for ft in fieldTypeList
@@ -102,6 +108,25 @@ CALL ${ft.name}$_DEV_ALLOCATE_DIM (DEV, UBOUNDS=IUBOUNDS, LBOUNDS=ILBOUNDS, MAP_
 
 END SUBROUTINE ${ft.name}$_DEV_ALLOCATE_HST
 
+SUBROUTINE ${ft.name}$_DEV_ALLOCATE_BLKS (DEV, HST, MAP_DEVPTR, BLK_SIZE, NBLKS)
+
+${ft.type}$, POINTER :: DEV(${ft.shape}$)
+${ft.type}$, POINTER :: HST(${ft.shape}$)
+LOGICAL, INTENT(IN) :: MAP_DEVPTR
+INTEGER(KIND=JPIM), INTENT(IN) :: BLK_SIZE
+INTEGER(KIND=JPIM), INTENT(IN) :: NBLKS
+
+INTEGER :: ILBOUNDS (${ft.rank}$)
+INTEGER :: IUBOUNDS (${ft.rank}$)
+
+ILBOUNDS = LBOUND (HST)
+IUBOUNDS = UBOUND (HST)
+IUBOUNDS(${ft.rank}$) = ILBOUNDS(${ft.rank}$) + BLK_SIZE*NBLKS - 1
+
+CALL ${ft.name}$_DEV_ALLOCATE_DIM (DEV, UBOUNDS=IUBOUNDS, LBOUNDS=ILBOUNDS, MAP_DEVPTR=MAP_DEVPTR)
+
+END SUBROUTINE ${ft.name}$_DEV_ALLOCATE_BLKS
+
 SUBROUTINE ${ft.name}$_DEV_ALLOCATE_DIM (DEV, UBOUNDS, LBOUNDS, MAP_DEVPTR)
 
 USE FIELD_STATISTICS_MODULE
@@ -206,6 +231,30 @@ IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_DEVICE_ALLOCATE (SIZE (DEV, K
 
 END SUBROUTINE ${ft.name}$_DEV_ALLOCATE_HST
 
+SUBROUTINE ${ft.name}$_DEV_ALLOCATE_BLKS (DEV, HST, MAP_DEVPTR, BLK_SIZE, NBLKS)
+
+USE FIELD_STATISTICS_MODULE
+
+${ft.type}$, POINTER :: DEV(${ft.shape}$)
+${ft.type}$, POINTER :: HST(${ft.shape}$)
+LOGICAL, INTENT(IN) :: MAP_DEVPTR
+INTEGER(KIND=JPIM), INTENT(IN) :: BLK_SIZE
+INTEGER(KIND=JPIM), INTENT(IN) :: NBLKS
+
+INTEGER :: ILBOUNDS (${ft.rank}$)
+INTEGER :: IUBOUNDS (${ft.rank}$)
+
+ILBOUNDS = LBOUND (HST)
+IUBOUNDS = UBOUND (HST)
+IUBOUNDS(${ft.rank}$) = ILBOUNDS(${ft.rank}$) + BLK_SIZE*NBLKS - 1
+ALLOCATE (DEV (${ ' '.join([f'ILBOUNDS({i}):IUBOUNDS(i})' for i in range (1, ft.rank+1)])}$))
+
+!$acc enter data create (DEV)
+
+IF (FIELD_STATISTICS_ENABLE) CALL FIELD_STATISTICS_DEVICE_ALLOCATE (SIZE (DEV, KIND=JPIB) * INT (KIND (DEV), KIND=JPIB))
+
+END SUBROUTINE ${ft.name}$_DEV_ALLOCATE_BLKS
+
 SUBROUTINE ${ft.name}$_DEV_DEALLOCATE (DEV, MAP_DEVPTR)
 
 USE FIELD_STATISTICS_MODULE

field_RANKSUFF_data_module.fypp

@@ -109,6 +109,23 @@ CONTAINS
 
   END SUBROUTINE
 
+  SUBROUTINE ${ftn}$_COPY_ARRAY_BLKS (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+
+    USE FIELD_ABORT_MODULE
+
+    ${ft.type}$, POINTER :: HST (${ft.shape}$), DEV (${ft.shape}$)
+    LOGICAL,                       INTENT (IN) :: MAP_DEVPTR
+    INTEGER (KIND=JPIM),           INTENT (IN) :: KDIR
+    INTEGER (KIND=JPIM), OPTIONAL, INTENT (IN) :: QUEUE
+
+    PROCEDURE (${ftn}$_COPY_INTF), POINTER :: FUNC
+
+    FUNC => ${ftn}$_COPY_FUNC (HST, DEV)
+
+    CALL FUNC (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
+
+  END SUBROUTINE
+
 #:for d in range (0, ft.rank+1)
   SUBROUTINE ${ftn}$_COPY_DIM${d}$_CONTIGUOUS (HST, DEV, MAP_DEVPTR, KDIR, QUEUE)
 #ifdef _OPENACC

field_RANKSUFF_module.fypp

@@ -72,6 +72,7 @@ CONTAINS
   PROCEDURE, PRIVATE :: ${ftn}$_GET_DEVICE_DATA
   PROCEDURE, PRIVATE :: COPY_DATA =>  ${ftn}$_COPY_DATA
   PROCEDURE :: CREATE_DEVICE_DATA => ${ftn}$_CREATE_DEVICE_DATA
+  PROCEDURE :: CREATE_DEVICE_DATA_BLKS => ${ftn}$_CREATE_DEVICE_BLKS
 #:if defined('WITH_FIAT')
   PROCEDURE :: CRC64 => ${ftn}$_CRC64
 #:endif
@@ -552,6 +553,22 @@ CONTAINS
     CALL DEV_ALLOCATE_HST (DEV=SELF%DEVPTR, HST=SELF%PTR, MAP_DEVPTR=SELF%MAP_DEVPTR, BLK_BOUNDS=BLK_BOUNDS)
   END SUBROUTINE
 
+  SUBROUTINE ${ftn}$_CREATE_DEVICE_DATA_BLKS(SELF, BLK_SIZE, NBLKS)
+
+    USE FIELD_ABORT_MODULE
+
+    CLASS(${ftn}$) :: SELF
+    INTEGER(KIND=JPIM), INTENT(IN) :: BLK_SIZE
+    INTEGER(KIND=JPIM), INTENT(IN) :: NBLKS
+
+    IF ( NBLKS < 2 ) THEN
+      CALL FIELD_ABORT("NBLKS MUST BE GREATER THAN 1 WHEN DOING A MULTI-BLOCK ALLOCATION ON DEVICE")
+    ENDIF
+
+    SELF%NBLKS = NBLKS
+    CALL DEV_ALLOCATE_BLKS(DEV=SELF%DEVPTR, HST=SELF%PTR, MAP_DEVPTR=SELF%MAP_DEVPTR, BLK_SIZE=BLKS_SIZE, NBLKS=NBLKS)
+  END SUBROUTINE
+
   SUBROUTINE ${ftn}$_GET_DEVICE_DATA (SELF, MODE, PTR, QUEUE, BLK_BOUNDS)
     CLASS(${ftn}$) :: SELF
     INTEGER (KIND=JPIM),           INTENT(IN)    :: MODE
@@ -560,6 +577,38 @@ CONTAINS
     INTEGER(KIND=JPIM), OPTIONAL,  INTENT(IN)    :: BLK_BOUNDS(2)
 
     INTEGER(KIND=JPIM)                           :: LBOUNDS(${ft.rank}$)
+
+    LBOUNDS=LBOUND(SELF%PTR)
+    IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN
+      CALL SELF%CREATE_DEVICE_DATA(BLK_BOUNDS=BLK_BOUNDS)
+    ENDIF
+    IF (IAND (SELF%GET_STATUS (), NDEVFRESH) == 0) THEN
+      CALL SELF%COPY_DATA (NH2D, QUEUE, BLK_BOUNDS=BLK_BOUNDS)
+      CALL SELF%SET_STATUS (IOR (SELF%GET_STATUS (), NDEVFRESH))
+    ENDIF
+    IF ( PRESENT(BLK_BOUNDS) ) THEN
+      PTR ( ${ft.lbptr_blk}$) => SELF%DEVPTR (${ft.devptr_blk}$)
+    ELSE
+      PTR (${ft.lbptr}$) => SELF%DEVPTR (${','.join(':' for _ in range(ft.rank))}$)
+    END IF
+    IF (IAND (MODE, NWR) /= 0) THEN
+      CALL SELF%SET_STATUS (IAND (SELF%GET_STATUS (), NOT (NHSTFRESH)))
+    ENDIF
+
+  END SUBROUTINE ${ftn}$_GET_DEVICE_DATA
+
+  SUBROUTINE ${ftn}$_GET_DEVICE_DATA_BLKS (SELF, MODE, PTR, QUEUE, BLK_BOUNDS, BLK)
+    CLASS(${ftn}$) :: SELF
+    INTEGER (KIND=JPIM),           INTENT(IN)    :: MODE
+    ${ft.type}$, POINTER,          INTENT(INOUT) :: PTR(${ft.shape}$)
+    INTEGER (KIND=JPIM), OPTIONAL, INTENT(IN)    :: QUEUE
+    INTEGER(KIND=JPIM), OPTIONAL,  INTENT(IN)    :: BLK_BOUNDS(2)
+
+    INTEGER(KIND=JPIM)                           :: LBOUNDS(${ft.rank}$)
+
+    IF (SELF%NBLKS > 1) THEN
+      CALL SELF
+    ENDIF
 
     LBOUNDS=LBOUND(SELF%PTR)
     IF (.NOT. ASSOCIATED (SELF%DEVPTR)) THEN

field_basic_module.F90

@@ -37,6 +37,7 @@ MODULE FIELD_BASIC_MODULE
   LOGICAL :: LOBJECT_COPIED = .FALSE.
   LOGICAL :: MAP_DEVPTR = .TRUE.
   INTEGER(KIND=JPIM) :: BLKID = 0
+  INTEGER(KIND=JPIM) :: NBLKS = 1
 
 CONTAINS
   PROCEDURE (FIELD_BASIC_SYNC),   DEFERRED :: SYNC_HOST_RDWR