From 5d5e575672b036494c0961b39193299f869b39b8 Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Thu, 28 Mar 2024 16:22:01 +0000 Subject: [PATCH 1/8] Create PERSISTENT fields with a last ubound /= 1 --- field_RANKSUFF_module.fypp | 24 ++++++++------ tests/CMakeLists.txt | 1 + tests/test_lastdim.F90 | 68 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 83 insertions(+), 10 deletions(-) create mode 100644 tests/test_lastdim.F90 diff --git a/field_RANKSUFF_module.fypp b/field_RANKSUFF_module.fypp index 2244bfb..d78615d 100644 --- a/field_RANKSUFF_module.fypp +++ b/field_RANKSUFF_module.fypp @@ -156,6 +156,7 @@ CONTAINS LOGICAL, INTENT(IN), OPTIONAL :: SYNC_ON_FINAL LOGICAL :: LLPERSISTENT + #include "abor1.intfb.h" LLPERSISTENT = .TRUE. @@ -166,7 +167,9 @@ CONTAINS ELSE SELF%PTR => DATA ENDIF + SELF%THREAD_BUFFER = .NOT. LLPERSISTENT + CALL SELF%SET_STATUS (NHSTFRESH) SELF%MAP_DEVPTR = INIT_MAP_DEVPTR @@ -207,6 +210,8 @@ CONTAINS LOGICAL, OPTIONAL, INTENT(IN) :: MAP_DEVPTR ${ft.type}$, OPTIONAL, INTENT(IN) :: INIT_VALUE LOGICAL :: IS_DELAYED + LOGICAL :: LLPERSISTENT + #include "abor1.intfb.h" IS_DELAYED = .FALSE. @@ -214,6 +219,9 @@ CONTAINS IS_DELAYED = DELAYED ENDIF + LLPERSISTENT = .FALSE. + IF (PRESENT (PERSISTENT)) LLPERSISTENT = PERSISTENT + #:if defined('CUDA') ! In the presence of CUDA we pin by default SELF%PINNED = INIT_PINNED_VALUE @@ -237,19 +245,15 @@ CONTAINS ELSE SELF%LBOUNDS=1 ENDIF + SELF%UBOUNDS=UBOUNDS - SELF%UBOUNDS(${ft.rank}$) = OML_MAX_THREADS () - ! By default we allocate thread-local temporaries - SELF%THREAD_BUFFER = .TRUE. + SELF%THREAD_BUFFER = .NOT. LLPERSISTENT - IF (PRESENT(PERSISTENT)) THEN - IF (PERSISTENT) THEN - SELF%THREAD_BUFFER = .FALSE. - SELF%LBOUNDS(${ft.rank}$) = 1 - SELF%UBOUNDS(${ft.rank}$) = UBOUNDS(${ft.rank}$) - END IF - END IF + IF (.NOT. LLPERSISTENT) THEN + SELF%LBOUNDS(${ft.rank}$) = 1 + SELF%UBOUNDS(${ft.rank}$) = OML_MAX_THREADS () + ENDIF CALL SELF%SET_STATUS (UNALLOCATED) IF (PRESENT(INIT_VALUE)) THEN diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index e5a7b56..35e93a6 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -25,6 +25,7 @@ target_compile_definitions( main.x PRIVATE $<${HAVE_CUDA}:_CUDA> ) ## Unit tests list(APPEND TEST_FILES + test_lastdim.F90 test_sizeof.F90 test_bc.F90 reshuffle.F90 diff --git a/tests/test_lastdim.F90 b/tests/test_lastdim.F90 new file mode 100644 index 0000000..1a59b51 --- /dev/null +++ b/tests/test_lastdim.F90 @@ -0,0 +1,68 @@ +! (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_OWNER_LASTDIM + +USE FIELD_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_ACCESS_MODULE +USE FIELD_ABORT_MODULE +USE PARKIND1 + +IMPLICIT NONE + +CLASS (FIELD_3RB), POINTER :: YLF => NULL() + +REAL (KIND=JPRB), POINTER :: ZDATA (:,:,:) +REAL (KIND=JPRB), POINTER :: ZVIEW (:,:) + +REAL (KIND=JPRB), ALLOCATABLE :: ZDATA0 (:,:,:) + + +INTEGER :: JBLK + +CALL FIELD_NEW (YLF, LBOUNDS=[10,1,3], UBOUNDS=[21,11,10], PERSISTENT=.TRUE.) + +ZDATA => GET_HOST_DATA_RDWR (YLF) + +PRINT *, " LBOUND (ZDATA) = ", LBOUND (ZDATA) +PRINT *, " UBOUND (ZDATA) = ", UBOUND (ZDATA) + +DO JBLK = LBOUND (ZDATA, 3), UBOUND (ZDATA, 3) + ZDATA (:,:,JBLK) = REAL (JBLK, JPRB) +ENDDO + +DO JBLK = LBOUND (ZDATA, 3), UBOUND (ZDATA, 3) + ZVIEW => YLF%GET_VIEW (BLOCK_INDEX=JBLK) + IF (ANY (ZVIEW /= REAL (JBLK, JPRB))) CALL FIELD_ABORT ('UNEXPECTED VALUES') +ENDDO + +CALL FIELD_DELETE (YLF) + +ALLOCATE (ZDATA0 (10:21, 1:11, 3:10)) + +CALL FIELD_NEW (YLF, LBOUNDS=[10,1,3], DATA=ZDATA0) + +ZDATA => GET_HOST_DATA_RDWR (YLF) + +PRINT *, " LBOUND (ZDATA) = ", LBOUND (ZDATA) +PRINT *, " UBOUND (ZDATA) = ", UBOUND (ZDATA) + +DO JBLK = LBOUND (ZDATA, 3), UBOUND (ZDATA, 3) + ZDATA (:,:,JBLK) = REAL (JBLK, JPRB) +ENDDO + +DO JBLK = LBOUND (ZDATA, 3), UBOUND (ZDATA, 3) + ZVIEW => YLF%GET_VIEW (BLOCK_INDEX=JBLK) + IF (ANY (ZVIEW /= REAL (JBLK, JPRB))) CALL FIELD_ABORT ('UNEXPECTED VALUES') +ENDDO + +CALL FIELD_DELETE (YLF) + +END PROGRAM TEST_OWNER_LASTDIM From 9f30946c51baee29ce83d67b79a68fd3355de8c4 Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Thu, 28 Mar 2024 21:21:19 +0000 Subject: [PATCH 2/8] Make shuffle & gather/scatter work with fields where last lower bound is different from one --- field_RANKSUFF_shuffle_module.fypp | 32 ++++--- field_gathscat_type_module.fypp | 8 +- tests/CMakeLists.txt | 2 + tests/gather_scatter_lastdim.F90 | 119 ++++++++++++++++++++++++++ tests/reshuffle_lastdim.F90 | 133 +++++++++++++++++++++++++++++ tests/test_lastdim.F90 | 2 + 6 files changed, 283 insertions(+), 13 deletions(-) create mode 100644 tests/gather_scatter_lastdim.F90 create mode 100644 tests/reshuffle_lastdim.F90 diff --git a/field_RANKSUFF_shuffle_module.fypp b/field_RANKSUFF_shuffle_module.fypp index 1ed6eb9..7379634 100644 --- a/field_RANKSUFF_shuffle_module.fypp +++ b/field_RANKSUFF_shuffle_module.fypp @@ -91,6 +91,9 @@ ELSEIF (LDFULL) THEN ! Return pointer on packed array PTR => GET_${what}$_DATA_${mode}$ (YLF) + ! Set last lbound to 1 + PTR (${','.join (list (map (lambda i: "LBOUND(PTR," + str (i) + "):", range (1, ft.rank))))}$, 1:) => PTR + ELSE PTR => GET_${what}$_DATA_RDONLY (YLF) @@ -104,8 +107,13 @@ ELSE ILBOUNDS = LBOUND (PTR) IUBOUNDS = UBOUND (PTR) + + ILBOUNDS (1) = 1 IUBOUNDS (1) = KLON + + ILBOUNDS (${ft.rank}$) = 1 IUBOUNDS (${ft.rank}$) = KGPBLKS + CALL FIELD_NEW (YLPAIR%YLGATH, LBOUNDS=ILBOUNDS, UBOUNDS=IUBOUNDS, PERSISTENT=.TRUE.) INDS => GET_${what}$_DATA_RDONLY (YDFINDS) @@ -124,8 +132,8 @@ CONTAINS SUBROUTINE PAIR_${ft.name}$_${what}$_${mode}$ (KNDS, PTRG, PTRS) -${ft.type}$, INTENT (OUT) :: PTRG(${ft.shape}$) -${ft.type}$, INTENT (IN) :: PTRS(${ft.shape}$) +${ft.type}$, INTENT (INOUT) :: PTRG(${ft.shape}$) +${ft.type}$, INTENT (IN) :: PTRS(${ft.shape}$) INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG @@ -161,7 +169,7 @@ END FUNCTION PAIR_${ft.name}$_GATHER_${what}$_DATA_${mode}$ SUBROUTINE PAIR_${ft.name}$_SCATTER_DATA (YDPAIR, YDFINDS) TYPE (${ft.name}$_SHUFFLE_PAIR), POINTER :: YDPAIR -CLASS (FIELD_3IM), POINTER :: YDFINDS +CLASS (FIELD_3IM), POINTER :: YDFINDS TYPE (${ft.name}$_SHUFFLE_PAIR), POINTER :: YLPAIR ${ft.type}$, POINTER :: PTRG(${ft.shape}$), PTRS(${ft.shape}$) @@ -178,6 +186,7 @@ DO WHILE (ASSOCIATED (YDPAIR)) INDS => GET_DEVICE_DATA_RDONLY (YDFINDS) PTRG => GET_DEVICE_DATA_RDONLY (YDPAIR%YLGATH) PTRS => GET_DEVICE_DATA_RDWR (YDPAIR%YLSCAT) + CALL ${ft.name}$_SCATTER_DEVICE_KERNEL (INDS, PTRG, PTRS) ELSEIF (YDPAIR%IWHAT == NHOST) THEN @@ -185,6 +194,7 @@ DO WHILE (ASSOCIATED (YDPAIR)) INDS => GET_HOST_DATA_RDONLY (YDFINDS) PTRG => GET_HOST_DATA_RDONLY (YDPAIR%YLGATH) PTRS => GET_HOST_DATA_RDWR (YDPAIR%YLSCAT) + CALL ${ft.name}$_SCATTER_HOST_KERNEL (INDS, PTRG, PTRS) ENDIF @@ -202,10 +212,12 @@ CONTAINS #:for what in ['DEVICE', 'HOST'] SUBROUTINE ${ft.name}$_SCATTER_${what}$_KERNEL (KNDS, PTRG, PTRS) -${ft.type}$, INTENT (IN) :: PTRG(${ft.shape}$) -${ft.type}$, INTENT (OUT) :: PTRS(${ft.shape}$) +${ft.type}$, INTENT (IN) :: PTRG(${ft.shape}$) +${ft.type}$, INTENT (INOUT) :: PTRS(${ft.shape}$) INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) -INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG +INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, JBOFF + +JBOFF = LBOUND (PTRG, ${ft.rank}$)-1 #:set dc = ', ' + (':, ' * (ft.rank-2)) @@ -214,13 +226,13 @@ INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG #:elif what == 'HOST' !$OMP PARALLEL DO PRIVATE (JBLKG, JLONG, JBLKS, JLONS) #:endif -DO JBLKG = 1, SIZE (KNDS, 3) +DO JBLKG = LBOUND (PTRG, ${ft.rank}$), UBOUND (PTRG, ${ft.rank}$) #:if what == 'DEVICE' !$acc loop vector private (JLONG, JBLKS, JLONS) #:endif - DO JLONG = 1, SIZE (KNDS, 2) - JLONS = KNDS (NLONDIM, JLONG, JBLKG) - JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) + DO JLONG = 1, SIZE (PTRG, 1) + JLONS = KNDS (NLONDIM, JLONG, JBLKG-JBOFF) + JBLKS = KNDS (NBLKDIM, JLONG, JBLKG-JBOFF) IF (JLONS > 0) THEN PTRS (JLONS${dc}$JBLKS) = PTRG (JLONG${dc}$JBLKG) ENDIF diff --git a/field_gathscat_type_module.fypp b/field_gathscat_type_module.fypp index c18c072..8d266ad 100644 --- a/field_gathscat_type_module.fypp +++ b/field_gathscat_type_module.fypp @@ -45,6 +45,7 @@ INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: KLON_S, KLON_G LOGICAL, POINTER :: LLF (:,:) INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, I1S, I2S +INTEGER (KIND=JPIM) :: JBOFF LLF => GET_HOST_DATA_RDONLY (YDFCOND) @@ -57,13 +58,14 @@ SELF%KGPTOT_S = KGPTOT SELF%KGPTOT_G = 0 +JBOFF = LBOUND (LLF, 2)-1 + DO JBLKS = 1, SELF%KGPBLKS_S I1S = 1 I2S = MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - 1) * SELF%KLON_S) - SELF%KGPTOT_G = SELF%KGPTOT_G + COUNT (LLF (I1S:I2S,JBLKS)) + SELF%KGPTOT_G = SELF%KGPTOT_G + COUNT (LLF (I1S:I2S,JBLKS+JBOFF)) ENDDO - IF (PRESENT (KLON_G)) THEN SELF%KLON_G = KLON_G ELSE @@ -94,7 +96,7 @@ ELSE JLONG = 1 DO JBLKS = 1, SELF%KGPBLKS_S DO JLONS = 1, MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - 1) * SELF%KLON_S) - IF (LLF (JLONS, JBLKS)) THEN + IF (LLF (JLONS, JBLKS+JBOFF)) THEN IF ((JLONG > SIZE (INDS, 2)) .OR. (JBLKG > SIZE (INDS, 3))) THEN CALL FIELD_ABORT ('INIT_FIELD_SHUFFLE: OUT OF BOUNDS') ENDIF diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index 35e93a6..f4f12fd 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -25,6 +25,8 @@ target_compile_definitions( main.x PRIVATE $<${HAVE_CUDA}:_CUDA> ) ## Unit tests list(APPEND TEST_FILES + gather_scatter_lastdim.F90 + reshuffle_lastdim.F90 test_lastdim.F90 test_sizeof.F90 test_bc.F90 diff --git a/tests/gather_scatter_lastdim.F90 b/tests/gather_scatter_lastdim.F90 new file mode 100644 index 0000000..cbefde3 --- /dev/null +++ b/tests/gather_scatter_lastdim.F90 @@ -0,0 +1,119 @@ +! (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 GATHER_SCATTER +!TEST THAT FIELD_GATHSCAT ONLY MODIFY VALUES THAT HAVE BEEN FILTERED +USE FIELD_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_ACCESS_MODULE +USE FIELD_GATHSCAT_MODULE +USE PARKIND1 +USE FIELD_ABORT_MODULE +IMPLICIT NONE + +TYPE (FIELD_GATHSCAT):: FGS +CLASS (FIELD_2LM), POINTER :: FTRIG => NULL() + +CHARACTER*4, PARAMETER :: CLTYPE (3) = ['PART', 'NULL', 'FULL'] + +INTEGER, PARAMETER :: NPROMA = 10, NFLEVG = 5, JBLKA = 2, JBLKB = 5, NGPBLKS = JBLKB - JBLKA + 1 + +LOGICAL :: TRIG (NPROMA,JBLKA:JBLKB) + +INTEGER :: I, J, JPASS + +INTEGER (KIND=JPIM), ALLOCATABLE :: D (:,:,:) +CLASS (FIELD_3IM), POINTER :: FD => NULL() + +INTEGER (KIND=JPIM), POINTER :: FILTERED_D(:,:,:) => NULL() + +DO JPASS = 1, 3 + + WRITE (0, '("===========> ",A4," <===========")') CLTYPE (JPASS) + + !CREATE A FILTER TO USE WITH THE GATHSCAT + + TRIG=.FALSE. + + SELECT CASE (JPASS) + CASE (1) + DO I =1,NPROMA + IF (MOD (I,2) == 0) THEN !ONLY MODIFY BLOCKS + TRIG (I, :)=.TRUE. + ENDIF + ENDDO + CASE (2) + TRIG = .FALSE. + CASE (3) + TRIG = .TRUE. + END SELECT + + CALL FIELD_NEW (FTRIG, DATA=TRIG, LBOUNDS=[1,JBLKA]) + + !CREATE THE FIELD TO BE FILTERED BY GATHSCAT + ALLOCATE (D (NPROMA, 0:NFLEVG, JBLKA:JBLKB)) + + D = 1 + + CALL FIELD_NEW (FD, DATA=D, LBOUNDS=[1,0,JBLKA]) + + WRITE (0, *) " LBOUND (D) = ", LBOUND (D) + WRITE (0, *) " UBOUND (D) = ", UBOUND (D) + + !FILTER DATA, WE GET A POINTER TO A CONTIGUOUS ARRAY CONTAINING ONLY THE FILTERED DATA + + CALL FGS%INIT (FTRIG, NPROMA*NGPBLKS) + + FILTERED_D => GATHER_HOST_DATA_RDWR (FGS, FD) + FILTERED_D = 2 !NOT ALL OF D WILL BE MODIFIED, ONLY THE FILTERED DATA + + WRITE (0, *) " LBOUND (FILTERED_D) = ", LBOUND (FILTERED_D) + WRITE (0, *) " UBOUND (FILTERED_D) = ", UBOUND (FILTERED_D) + + IF (CLTYPE (JPASS) /= 'NULL') THEN + IF (SIZE (FILTERED_D, 1) /= NPROMA) CALL FIELD_ABORT ('NPROMA MISMATCH') + IF (LBOUND (FILTERED_D, 1) /= 1) CALL FIELD_ABORT ('LBOUND MISMATCH') + IF (LBOUND (FILTERED_D, 2) /= 0) CALL FIELD_ABORT ('LBOUND MISMATCH') + IF (UBOUND (FILTERED_D, 2) /= NFLEVG) CALL FIELD_ABORT ('UBOUND MISMATCH') + ENDIF + + !ACTUALLY UPDATE THE D ARRAY WITH THE MODIFIED DATA + + CALL FGS%SCATTER () + + SELECT CASE (JPASS) + CASE (1) + DO I = 1, NPROMA + IF (MOD (I,2) == 0)THEN + IF (.NOT. ALL(D(I,:,:)==2)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + ELSE + IF (.NOT. ALL(D(I,:,:)==1)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + ENDIF + ENDDO + CASE (2) + IF (.NOT. ALL (D == 1)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + CASE (3) + IF (.NOT. ALL (D == 2)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + END SELECT + + DEALLOCATE (D) + + CALL FIELD_DELETE (FTRIG) + +ENDDO + +END PROGRAM diff --git a/tests/reshuffle_lastdim.F90 b/tests/reshuffle_lastdim.F90 new file mode 100644 index 0000000..e3eef8d --- /dev/null +++ b/tests/reshuffle_lastdim.F90 @@ -0,0 +1,133 @@ +! (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 RESHUFFLE + +USE FIELD_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_ACCESS_MODULE +USE FIELD_SHUFFLE_MODULE +USE PARKIND1 +USE FIELD_ABORT_MODULE + +IMPLICIT NONE + +TYPE (FIELD_SHUFFLE):: FGS + +INTEGER, PARAMETER :: NPROMA1 = 10, JBLK1A = 2, JBLK1B = 5, NGPBLKS1 = JBLK1B - JBLK1A + 1 +INTEGER, PARAMETER :: NPROMA2 = 6 +INTEGER, PARAMETER :: NFLEVG = 3 + +INTEGER :: JLON, JBLK, JLEV, JPASS + +INTEGER (KIND=JPIM), ALLOCATABLE :: D1 (:,:,:) + +CLASS (FIELD_3IM), POINTER :: FD => NULL () + +INTEGER (KIND=JPIM), POINTER :: Z2 (:,:,:) => NULL () + +INTEGER (KIND=JPIM) :: FUNC + +FUNC (JLON, JBLK) = 1000 * JBLK + JLON + +! First pass with modification on CPU, second pass on GPU +DO JPASS = 1, 2 + + ALLOCATE (D1 (NPROMA1, 0:NFLEVG, JBLK1A:JBLK1B)) + + PRINT *, " NPROMA1 = ", NPROMA2 + PRINT *, " LBOUND (D1) = ", LBOUND (D1) + PRINT *, " UBOUND (D1) = ", UBOUND (D1) + + DO JBLK = JBLK1A, JBLK1B + DO JLON = 1, NPROMA1 + D1 (JLON, :, JBLK) = FUNC (JLON, JBLK) + ENDDO + ENDDO + + DO JBLK = JBLK1A, JBLK1B + WRITE (*, '(20I12)') D1 (:, 1, JBLK) + ENDDO + + CALL FIELD_NEW (FD, DATA=D1, LBOUNDS=[1, 0, JBLK1A]) + + ! Reshuffle on NPROMA2 arrays + + CALL FGS%INIT (KGPTOT=NPROMA1*NGPBLKS1, KLON_S=NPROMA1, KLON_G=NPROMA2) + + IF (JPASS == 1) THEN + Z2 => GATHER_HOST_DATA_RDWR (FGS, FD) + ELSEIF (JPASS == 2) THEN + Z2 => GATHER_DEVICE_DATA_RDWR (FGS, FD) + ENDIF + + PRINT *, " NPROMA2 = ", NPROMA2 + PRINT *, " LBOUND (Z2) = ", LBOUND (Z2) + PRINT *, " UBOUND (Z2) = ", UBOUND (Z2) + + IF (NPROMA2 /= SIZE (Z2, 1)) CALL FIELD_ABORT ('NPROMA MISMATCH') + IF (LBOUND (Z2, 2) /= LBOUND (D1, 2)) CALL FIELD_ABORT ('DIMENSION MISMATCH') + IF (UBOUND (Z2, 2) /= UBOUND (D1, 2)) CALL FIELD_ABORT ('DIMENSION MISMATCH') + + DO JBLK = 1, SIZE (Z2, 3) + WRITE (*, '(20I12)') Z2 (:, 1, JBLK) + ENDDO + + IF (JPASS == 1) THEN + DO JBLK = 1, SIZE (Z2, 3) + DO JLEV = 0, NFLEVG + DO JLON = 1, SIZE (Z2, 1) + Z2 (JLON, JLEV, JBLK) = (JPASS + 1) * Z2 (JLON, JLEV, JBLK) + ENDDO + ENDDO + ENDDO + ELSE +!$acc parallel loop gang present (Z2) + DO JBLK = 1, SIZE (Z2, 3) +!$acc loop vector + DO JLON = 1, SIZE (Z2, 1) + DO JLEV = 0, NFLEVG + Z2 (JLON, JLEV, JBLK) = (JPASS + 1) * Z2 (JLON, JLEV, JBLK) + ENDDO + ENDDO + ENDDO + ENDIF + + ! Reshuffle back to NPROMA1 array + + CALL FGS%SCATTER () + + ! Synchronize D1 to host (if data was modified on GPU) + CALL FIELD_DELETE (FD) + + PRINT *, '------------' + + DO JBLK = JBLK1A, JBLK1B + WRITE (*, '(20I12)') D1 (:, 1, JBLK) + ENDDO + + DO JBLK = JBLK1A, JBLK1B + DO JLEV = 0, NFLEVG + DO JLON = 1, NPROMA1 + IF (D1 (JLON, JLEV, JBLK) /= (JPASS + 1) * FUNC (JLON, JBLK)) THEN + PRINT *, " JPASS = ", JPASS, " JLON = ", JLON, " JLEV = ", JLEV, & + & " JBLK = ", JBLK, " D1 = ", D1 (JLON, JLEV, JBLK), & + & (JPASS + 1) * FUNC (JLON, JBLK) + CALL FIELD_ABORT ('VALUE ERROR') + ENDIF + ENDDO + ENDDO + ENDDO + + DEALLOCATE (D1) + + +ENDDO + +END PROGRAM diff --git a/tests/test_lastdim.F90 b/tests/test_lastdim.F90 index 1a59b51..b818ec5 100644 --- a/tests/test_lastdim.F90 +++ b/tests/test_lastdim.F90 @@ -13,6 +13,7 @@ PROGRAM TEST_OWNER_LASTDIM USE FIELD_FACTORY_MODULE USE FIELD_ACCESS_MODULE USE FIELD_ABORT_MODULE +USE FIELD_SHUFFLE_MODULE USE PARKIND1 IMPLICIT NONE @@ -24,6 +25,7 @@ PROGRAM TEST_OWNER_LASTDIM REAL (KIND=JPRB), ALLOCATABLE :: ZDATA0 (:,:,:) +TYPE (FIELD_SHUFFLE) :: FGS INTEGER :: JBLK From 6975ba236a1b7e821c9a5e821df2ab3f9543c90d Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Tue, 2 Apr 2024 13:17:21 +0000 Subject: [PATCH 3/8] Reshuffle block sections of fields --- field_shuffle_type_module.fypp | 9 +++++++-- tests/reshuffle_lastdim.F90 | 29 ++++++++++++++++++++++------- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/field_shuffle_type_module.fypp b/field_shuffle_type_module.fypp index 17ff810..67de35e 100644 --- a/field_shuffle_type_module.fypp +++ b/field_shuffle_type_module.fypp @@ -46,16 +46,21 @@ INTEGER (KIND=JPIM), PARAMETER :: NLONDIM = 1, NBLKDIM = 2 CONTAINS -SUBROUTINE INIT_FIELD_SHUFFLE (SELF, KGPTOT, KLON_S, KLON_G) +SUBROUTINE INIT_FIELD_SHUFFLE (SELF, KGPTOT, KLON_S, KLON_G, KBLKOFF) USE FIELD_ABORT_MODULE CLASS (FIELD_SHUFFLE) :: SELF INTEGER (KIND=JPIM), INTENT (IN) :: KGPTOT INTEGER (KIND=JPIM), INTENT (IN) :: KLON_S, KLON_G +INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: KBLKOFF INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, I1S, I2S +INTEGER (KIND=JPIM) :: IBLKOFF + +IBLKOFF = 0 +IF (PRESENT (KBLKOFF)) IBLKOFF = KBLKOFF SELF%KGPTOT_S = KGPTOT SELF%KLON_S = KLON_S @@ -79,7 +84,7 @@ JLONG = 1 DO JBLKS = 1, SELF%KGPBLKS_S DO JLONS = 1, MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - 1) * SELF%KLON_S) INDS (NLONDIM, JLONG, JBLKG) = JLONS - INDS (NBLKDIM, JLONG, JBLKG) = JBLKS + INDS (NBLKDIM, JLONG, JBLKG) = JBLKS + IBLKOFF JLONG = JLONG + 1 IF (JLONG > SELF%KLON_G) THEN JLONG = 1 diff --git a/tests/reshuffle_lastdim.F90 b/tests/reshuffle_lastdim.F90 index e3eef8d..bcc0df3 100644 --- a/tests/reshuffle_lastdim.F90 +++ b/tests/reshuffle_lastdim.F90 @@ -24,7 +24,8 @@ PROGRAM RESHUFFLE INTEGER, PARAMETER :: NPROMA2 = 6 INTEGER, PARAMETER :: NFLEVG = 3 -INTEGER :: JLON, JBLK, JLEV, JPASS +INTEGER :: JLON, JBLK, JLEV, JPASS, JBOFF +INTEGER :: JBLK1L, JBLK1U INTEGER (KIND=JPIM), ALLOCATABLE :: D1 (:,:,:) @@ -36,30 +37,43 @@ PROGRAM RESHUFFLE FUNC (JLON, JBLK) = 1000 * JBLK + JLON +DO JBOFF = 1, 2 ! First pass with modification on CPU, second pass on GPU DO JPASS = 1, 2 - ALLOCATE (D1 (NPROMA1, 0:NFLEVG, JBLK1A:JBLK1B)) + PRINT *, "=========> JPASS = ", JPASS, ", JBOFF = ", JBOFF, " <=========" + + IF (JBOFF == 1) THEN + JBLK1L = JBLK1A + JBLK1U = JBLK1B + ELSEIF (JBOFF == 2) THEN + JBLK1L = 1 + JBLK1U = 7 + ELSE + CALL FIELD_ABORT ('UNEXPECTED JBOFF') + ENDIF + + ALLOCATE (D1 (NPROMA1, 0:NFLEVG, JBLK1L:JBLK1U)) PRINT *, " NPROMA1 = ", NPROMA2 PRINT *, " LBOUND (D1) = ", LBOUND (D1) PRINT *, " UBOUND (D1) = ", UBOUND (D1) - DO JBLK = JBLK1A, JBLK1B + DO JBLK = JBLK1L, JBLK1U DO JLON = 1, NPROMA1 D1 (JLON, :, JBLK) = FUNC (JLON, JBLK) ENDDO ENDDO - DO JBLK = JBLK1A, JBLK1B + DO JBLK = JBLK1L, JBLK1U WRITE (*, '(20I12)') D1 (:, 1, JBLK) ENDDO - CALL FIELD_NEW (FD, DATA=D1, LBOUNDS=[1, 0, JBLK1A]) + CALL FIELD_NEW (FD, DATA=D1, LBOUNDS=[1, 0, JBLK1L]) ! Reshuffle on NPROMA2 arrays - CALL FGS%INIT (KGPTOT=NPROMA1*NGPBLKS1, KLON_S=NPROMA1, KLON_G=NPROMA2) + CALL FGS%INIT (KGPTOT=NPROMA1*NGPBLKS1, KLON_S=NPROMA1, KLON_G=NPROMA2, KBLKOFF=JBLK1A-JBLK1L) IF (JPASS == 1) THEN Z2 => GATHER_HOST_DATA_RDWR (FGS, FD) @@ -108,7 +122,7 @@ PROGRAM RESHUFFLE PRINT *, '------------' - DO JBLK = JBLK1A, JBLK1B + DO JBLK = JBLK1L, JBLK1U WRITE (*, '(20I12)') D1 (:, 1, JBLK) ENDDO @@ -128,6 +142,7 @@ PROGRAM RESHUFFLE DEALLOCATE (D1) +ENDDO ENDDO END PROGRAM From 90f5591803056b0e74a50a8891f30d90cc023c20 Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Tue, 2 Apr 2024 13:19:20 +0000 Subject: [PATCH 4/8] Cleaning --- field_RANKSUFF_shuffle_module.fypp | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/field_RANKSUFF_shuffle_module.fypp b/field_RANKSUFF_shuffle_module.fypp index 7379634..158c14c 100644 --- a/field_RANKSUFF_shuffle_module.fypp +++ b/field_RANKSUFF_shuffle_module.fypp @@ -215,9 +215,7 @@ SUBROUTINE ${ft.name}$_SCATTER_${what}$_KERNEL (KNDS, PTRG, PTRS) ${ft.type}$, INTENT (IN) :: PTRG(${ft.shape}$) ${ft.type}$, INTENT (INOUT) :: PTRS(${ft.shape}$) INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) -INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, JBOFF - -JBOFF = LBOUND (PTRG, ${ft.rank}$)-1 +INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG #:set dc = ', ' + (':, ' * (ft.rank-2)) @@ -231,8 +229,8 @@ DO JBLKG = LBOUND (PTRG, ${ft.rank}$), UBOUND (PTRG, ${ft.rank}$) !$acc loop vector private (JLONG, JBLKS, JLONS) #:endif DO JLONG = 1, SIZE (PTRG, 1) - JLONS = KNDS (NLONDIM, JLONG, JBLKG-JBOFF) - JBLKS = KNDS (NBLKDIM, JLONG, JBLKG-JBOFF) + JLONS = KNDS (NLONDIM, JLONG, JBLKG) + JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) IF (JLONS > 0) THEN PTRS (JLONS${dc}$JBLKS) = PTRG (JLONG${dc}$JBLKG) ENDIF From 21b7d7044ff6be1cd85f17c3c1239e1f51c49ee3 Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Tue, 2 Apr 2024 14:56:32 +0000 Subject: [PATCH 5/8] Adapt to partial block ranges --- field_RANKSUFF_shuffle_module.fypp | 12 ++--- field_gathscat_type_module.fypp | 6 ++- field_shuffle_type_module.fypp | 4 +- tests/gather_scatter_lastdim.F90 | 71 +++++++++++++++++++++--------- tests/reshuffle_lastdim.F90 | 25 +++++++---- 5 files changed, 79 insertions(+), 39 deletions(-) diff --git a/field_RANKSUFF_shuffle_module.fypp b/field_RANKSUFF_shuffle_module.fypp index 158c14c..8efd904 100644 --- a/field_RANKSUFF_shuffle_module.fypp +++ b/field_RANKSUFF_shuffle_module.fypp @@ -132,8 +132,8 @@ CONTAINS SUBROUTINE PAIR_${ft.name}$_${what}$_${mode}$ (KNDS, PTRG, PTRS) -${ft.type}$, INTENT (INOUT) :: PTRG(${ft.shape}$) -${ft.type}$, INTENT (IN) :: PTRS(${ft.shape}$) +${ft.type}$, POINTER :: PTRG(${ft.shape}$) +${ft.type}$, POINTER :: PTRS(${ft.shape}$) INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG @@ -212,8 +212,8 @@ CONTAINS #:for what in ['DEVICE', 'HOST'] SUBROUTINE ${ft.name}$_SCATTER_${what}$_KERNEL (KNDS, PTRG, PTRS) -${ft.type}$, INTENT (IN) :: PTRG(${ft.shape}$) -${ft.type}$, INTENT (INOUT) :: PTRS(${ft.shape}$) +${ft.type}$, POINTER :: PTRG(${ft.shape}$) +${ft.type}$, POINTER :: PTRS(${ft.shape}$) INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG @@ -224,11 +224,11 @@ INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG #:elif what == 'HOST' !$OMP PARALLEL DO PRIVATE (JBLKG, JLONG, JBLKS, JLONS) #:endif -DO JBLKG = LBOUND (PTRG, ${ft.rank}$), UBOUND (PTRG, ${ft.rank}$) +DO JBLKG = 1, SIZE (KNDS, 3) #:if what == 'DEVICE' !$acc loop vector private (JLONG, JBLKS, JLONS) #:endif - DO JLONG = 1, SIZE (PTRG, 1) + DO JLONG = 1, SIZE (KNDS, 2) JLONS = KNDS (NLONDIM, JLONG, JBLKG) JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) IF (JLONS > 0) THEN diff --git a/field_gathscat_type_module.fypp b/field_gathscat_type_module.fypp index 8d266ad..28d9f8b 100644 --- a/field_gathscat_type_module.fypp +++ b/field_gathscat_type_module.fypp @@ -78,7 +78,9 @@ SELF%KGPTOT = SELF%KGPTOT_G SELF%KLON = SELF%KLON_G SELF%KGPBLKS = SELF%KGPBLKS_G -SELF%LFULL = SELF%KGPTOT_G == SELF%KGPTOT_S +! Does not work anymore with partial block ranges +!SELF%LFULL = SELF%KGPTOT_G == SELF%KGPTOT_S +SELF%LFULL = .FALSE. SELF%LNULL = SELF%KGPTOT_G == 0 IF (SELF%LNULL) THEN @@ -101,7 +103,7 @@ ELSE CALL FIELD_ABORT ('INIT_FIELD_SHUFFLE: OUT OF BOUNDS') ENDIF INDS (NLONDIM, JLONG, JBLKG) = JLONS - INDS (NBLKDIM, JLONG, JBLKG) = JBLKS + INDS (NBLKDIM, JLONG, JBLKG) = JBLKS+JBOFF JLONG = JLONG + 1 IF (JLONG > SELF%KLON_G) THEN JLONG = 1 diff --git a/field_shuffle_type_module.fypp b/field_shuffle_type_module.fypp index 67de35e..1e75d00 100644 --- a/field_shuffle_type_module.fypp +++ b/field_shuffle_type_module.fypp @@ -59,7 +59,7 @@ INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, I1S, I2S INTEGER (KIND=JPIM) :: IBLKOFF -IBLKOFF = 0 +IBLKOFF = 1 IF (PRESENT (KBLKOFF)) IBLKOFF = KBLKOFF SELF%KGPTOT_S = KGPTOT @@ -84,7 +84,7 @@ JLONG = 1 DO JBLKS = 1, SELF%KGPBLKS_S DO JLONS = 1, MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - 1) * SELF%KLON_S) INDS (NLONDIM, JLONG, JBLKG) = JLONS - INDS (NBLKDIM, JLONG, JBLKG) = JBLKS + IBLKOFF + INDS (NBLKDIM, JLONG, JBLKG) = JBLKS + IBLKOFF-1 JLONG = JLONG + 1 IF (JLONG > SELF%KLON_G) THEN JLONG = 1 diff --git a/tests/gather_scatter_lastdim.F90 b/tests/gather_scatter_lastdim.F90 index cbefde3..3dd5bbc 100644 --- a/tests/gather_scatter_lastdim.F90 +++ b/tests/gather_scatter_lastdim.F90 @@ -26,16 +26,18 @@ PROGRAM GATHER_SCATTER LOGICAL :: TRIG (NPROMA,JBLKA:JBLKB) -INTEGER :: I, J, JPASS +INTEGER :: I, J, JPASS, JBOFF +INTEGER :: JBLKL, JBLKU, JBLK INTEGER (KIND=JPIM), ALLOCATABLE :: D (:,:,:) CLASS (FIELD_3IM), POINTER :: FD => NULL() INTEGER (KIND=JPIM), POINTER :: FILTERED_D(:,:,:) => NULL() +DO JBOFF = 1, 2 DO JPASS = 1, 3 - WRITE (0, '("===========> ",A4," <===========")') CLTYPE (JPASS) + WRITE (0, '("===========> PASS = ",A4,", JBOFF ",I0," <===========")') CLTYPE (JPASS), JBOFF !CREATE A FILTER TO USE WITH THE GATHSCAT @@ -53,15 +55,25 @@ PROGRAM GATHER_SCATTER CASE (3) TRIG = .TRUE. END SELECT + + IF (JBOFF == 1) THEN + JBLKL = JBLKA + JBLKU = JBLKB + ELSEIF (JBOFF == 2) THEN + JBLKL = 1 + JBLKU = 7 + ELSE + CALL FIELD_ABORT ('UNEXPECTED JBOFF') + ENDIF CALL FIELD_NEW (FTRIG, DATA=TRIG, LBOUNDS=[1,JBLKA]) !CREATE THE FIELD TO BE FILTERED BY GATHSCAT - ALLOCATE (D (NPROMA, 0:NFLEVG, JBLKA:JBLKB)) + ALLOCATE (D (NPROMA, 0:NFLEVG, JBLKL:JBLKU)) D = 1 - CALL FIELD_NEW (FD, DATA=D, LBOUNDS=[1,0,JBLKA]) + CALL FIELD_NEW (FD, DATA=D, LBOUNDS=[1,0,JBLKL]) WRITE (0, *) " LBOUND (D) = ", LBOUND (D) WRITE (0, *) " UBOUND (D) = ", UBOUND (D) @@ -71,7 +83,7 @@ PROGRAM GATHER_SCATTER CALL FGS%INIT (FTRIG, NPROMA*NGPBLKS) FILTERED_D => GATHER_HOST_DATA_RDWR (FGS, FD) - FILTERED_D = 2 !NOT ALL OF D WILL BE MODIFIED, ONLY THE FILTERED DATA + FILTERED_D (:,:,:) = 2 !NOT ALL OF D WILL BE MODIFIED, ONLY THE FILTERED DATA WRITE (0, *) " LBOUND (FILTERED_D) = ", LBOUND (FILTERED_D) WRITE (0, *) " UBOUND (FILTERED_D) = ", UBOUND (FILTERED_D) @@ -87,33 +99,50 @@ PROGRAM GATHER_SCATTER CALL FGS%SCATTER () - SELECT CASE (JPASS) - CASE (1) - DO I = 1, NPROMA - IF (MOD (I,2) == 0)THEN - IF (.NOT. ALL(D(I,:,:)==2)) THEN + DO JBLK = JBLKL, JBLKU + SELECT CASE (JPASS) + CASE (1) + IF ((JBLKA <= JBLK) .AND. (JBLK <= JBLKB)) THEN + DO I = 1, NPROMA + IF (MOD (I, 2) == 0)THEN + IF (ANY (D (I,:,JBLK) /= 2)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + ELSE + IF (ANY (D (I,:,JBLK) /= 1)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + ENDIF + ENDDO + ELSE + IF (ANY (D (:,:,JBLK) /= 1)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + ENDIF + CASE (2) +! Nothing has been touched + IF (ANY (D (:,:,JBLK) /= 1)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + CASE (3) +! All blocks between JBLKA and JBLKB have changed + IF ((JBLKA <= JBLK) .AND. (JBLK <= JBLKB)) THEN + IF (ANY (D (:,:,JBLK) /= 2)) THEN CALL FIELD_ABORT ("ERROR") ENDIF ELSE - IF (.NOT. ALL(D(I,:,:)==1)) THEN + IF (ANY (D (:,:,JBLK) /= 1)) THEN CALL FIELD_ABORT ("ERROR") ENDIF ENDIF - ENDDO - CASE (2) - IF (.NOT. ALL (D == 1)) THEN - CALL FIELD_ABORT ("ERROR") - ENDIF - CASE (3) - IF (.NOT. ALL (D == 2)) THEN - CALL FIELD_ABORT ("ERROR") - ENDIF - END SELECT + END SELECT + ENDDO DEALLOCATE (D) CALL FIELD_DELETE (FTRIG) ENDDO +ENDDO END PROGRAM diff --git a/tests/reshuffle_lastdim.F90 b/tests/reshuffle_lastdim.F90 index bcc0df3..523af09 100644 --- a/tests/reshuffle_lastdim.F90 +++ b/tests/reshuffle_lastdim.F90 @@ -55,7 +55,7 @@ PROGRAM RESHUFFLE ALLOCATE (D1 (NPROMA1, 0:NFLEVG, JBLK1L:JBLK1U)) - PRINT *, " NPROMA1 = ", NPROMA2 + PRINT *, " NPROMA1 = ", NPROMA1 PRINT *, " LBOUND (D1) = ", LBOUND (D1) PRINT *, " UBOUND (D1) = ", UBOUND (D1) @@ -73,7 +73,7 @@ PROGRAM RESHUFFLE ! Reshuffle on NPROMA2 arrays - CALL FGS%INIT (KGPTOT=NPROMA1*NGPBLKS1, KLON_S=NPROMA1, KLON_G=NPROMA2, KBLKOFF=JBLK1A-JBLK1L) + CALL FGS%INIT (KGPTOT=NPROMA1*NGPBLKS1, KLON_S=NPROMA1, KLON_G=NPROMA2, KBLKOFF=JBLK1A) IF (JPASS == 1) THEN Z2 => GATHER_HOST_DATA_RDWR (FGS, FD) @@ -126,14 +126,23 @@ PROGRAM RESHUFFLE WRITE (*, '(20I12)') D1 (:, 1, JBLK) ENDDO - DO JBLK = JBLK1A, JBLK1B + DO JBLK = JBLK1L, JBLK1U DO JLEV = 0, NFLEVG DO JLON = 1, NPROMA1 - IF (D1 (JLON, JLEV, JBLK) /= (JPASS + 1) * FUNC (JLON, JBLK)) THEN - PRINT *, " JPASS = ", JPASS, " JLON = ", JLON, " JLEV = ", JLEV, & - & " JBLK = ", JBLK, " D1 = ", D1 (JLON, JLEV, JBLK), & - & (JPASS + 1) * FUNC (JLON, JBLK) - CALL FIELD_ABORT ('VALUE ERROR') + IF ((JBLK1A .LE. JBLK) .AND. (JBLK .LE. JBLK1B)) THEN + IF (D1 (JLON, JLEV, JBLK) /= (JPASS + 1) * FUNC (JLON, JBLK)) THEN + PRINT *, " JPASS = ", JPASS, " JLON = ", JLON, " JLEV = ", JLEV, & + & " JBLK = ", JBLK, " D1 = ", D1 (JLON, JLEV, JBLK), & + & (JPASS + 1) * FUNC (JLON, JBLK) + CALL FIELD_ABORT ('VALUE ERROR') + ENDIF + ELSE + IF (D1 (JLON, JLEV, JBLK) /= FUNC (JLON, JBLK)) THEN + PRINT *, " JPASS = ", JPASS, " JLON = ", JLON, " JLEV = ", JLEV, & + & " JBLK = ", JBLK, " D1 = ", D1 (JLON, JLEV, JBLK), & + & FUNC (JLON, JBLK) + CALL FIELD_ABORT ('VALUE ERROR') + ENDIF ENDIF ENDDO ENDDO From 2068661a9642de84dfe69e67b3b7d394675aa28b Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Wed, 3 Apr 2024 09:23:49 +0000 Subject: [PATCH 6/8] Improve block range reshuffling --- field_RANKSUFF_gather_module.fypp | 3 ++- field_RANKSUFF_shuffle_module.fypp | 11 +++++++++-- field_gathscat_type_module.fypp | 15 ++++++++++----- field_shuffle_type_module.fypp | 4 ++++ 4 files changed, 25 insertions(+), 8 deletions(-) diff --git a/field_RANKSUFF_gather_module.fypp b/field_RANKSUFF_gather_module.fypp index bf4833d..304e87c 100644 --- a/field_RANKSUFF_gather_module.fypp +++ b/field_RANKSUFF_gather_module.fypp @@ -53,7 +53,8 @@ CLASS (${ft.name}$), POINTER, INTENT (IN) :: YLF ${ft.type}$, POINTER :: PTR(${ft.shape}$) -PTR => PAIR_GATHER_${what}$_DATA_${mode}$ (SELF%${ft.name}$_LIST, SELF%LNULL, SELF%LFULL, SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, YLF) +PTR => PAIR_GATHER_${what}$_DATA_${mode}$ (SELF%${ft.name}$_LIST, SELF%LNULL, SELF%LFULL, & +& SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, YLF, SELF%KBLKMIN, SELF%KBLKMAX) END FUNCTION ${ft.name}$_GATHER_${what}$_DATA_${mode}$ diff --git a/field_RANKSUFF_shuffle_module.fypp b/field_RANKSUFF_shuffle_module.fypp index 8efd904..3acb044 100644 --- a/field_RANKSUFF_shuffle_module.fypp +++ b/field_RANKSUFF_shuffle_module.fypp @@ -66,12 +66,14 @@ CONTAINS #:for what in ['DEVICE', 'HOST'] #:for mode in ['RDONLY', 'RDWR'] -FUNCTION PAIR_${ft.name}$_GATHER_${what}$_DATA_${mode}$ (YDPAIR, LDNULL, LDFULL, KLON, KGPBLKS, YDFINDS, YLF) RESULT (PTR) +FUNCTION PAIR_${ft.name}$_GATHER_${what}$_DATA_${mode}$ (YDPAIR, LDNULL, LDFULL, KLON, KGPBLKS, YDFINDS, YLF, KBLKMIN, KBLKMAX) RESULT (PTR) TYPE (${ft.name}$_SHUFFLE_PAIR), POINTER :: YDPAIR LOGICAL, INTENT (IN) :: LDNULL, LDFULL INTEGER (KIND=JPIM), INTENT (IN) :: KLON, KGPBLKS CLASS (FIELD_3IM), POINTER :: YDFINDS CLASS (${ft.name}$), POINTER, INTENT (IN) :: YLF +INTEGER (KIND=JPIM), INTENT (IN) :: KBLKMIN +INTEGER (KIND=JPIM), INTENT (IN) :: KBLKMAX ${ft.type}$, POINTER :: PTR(${ft.shape}$), ZTRG(${ft.shape}$), ZTRS(${ft.shape}$) ${ft.type}$, POINTER :: PTR1(${ft.shape}$) @@ -92,7 +94,12 @@ ELSEIF (LDFULL) THEN PTR => GET_${what}$_DATA_${mode}$ (YLF) ! Set last lbound to 1 - PTR (${','.join (list (map (lambda i: "LBOUND(PTR," + str (i) + "):", range (1, ft.rank))))}$, 1:) => PTR + + ILBOUNDS = LBOUND (PTR) + + PTR1 => PTR (${','.join ([':'] * (ft.rank-1))}$, KBLKMIN:KBLKMAX) + + PTR (${','.join (list (map (lambda i: "ILBOUNDS(" + str (i) + "):", range (1, ft.rank))))}$, 1:) => PTR1 ELSE diff --git a/field_gathscat_type_module.fypp b/field_gathscat_type_module.fypp index 28d9f8b..3ff2cf4 100644 --- a/field_gathscat_type_module.fypp +++ b/field_gathscat_type_module.fypp @@ -33,7 +33,7 @@ INTEGER (KIND=JPIM), PARAMETER :: NLONDIM = 1, NBLKDIM = 2 CONTAINS -SUBROUTINE INIT_FIELD_GATHSCAT (SELF, YDFCOND, KGPTOT, KLON_S, KLON_G) +SUBROUTINE INIT_FIELD_GATHSCAT (SELF, YDFCOND, KGPTOT, KLON_S, KLON_G, KBLKMIN, KBLKMAX) USE FIELD_ABORT_MODULE @@ -41,17 +41,22 @@ CLASS (FIELD_GATHSCAT) :: SELF CLASS (FIELD_2LM), POINTER :: YDFCOND INTEGER (KIND=JPIM), INTENT (IN) :: KGPTOT INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: KLON_S, KLON_G +INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: KBLKMIN, KBLKMAX LOGICAL, POINTER :: LLF (:,:) INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, I1S, I2S INTEGER (KIND=JPIM) :: JBOFF - LLF => GET_HOST_DATA_RDONLY (YDFCOND) +SELF%KBLKMIN = LBOUND (LLF, 2) +IF (PRESENT (KBLKMIN)) SELF%KBLKMIN = KBLKMIN +SELF%KBLKMAX = UBOUND (LLF, 2) +IF (PRESENT (KBLKMAX)) SELF%KBLKMAX = KBLKMAX + SELF%KLON_S = SIZE (LLF, 1) -SELF%KGPBLKS_S = SIZE (LLF, 2) +SELF%KGPBLKS_S = SELF%KBLKMAX - SELF%KBLKMIN + 1 SELF%KGPTOT_S = KGPTOT ! Reduction @@ -79,8 +84,8 @@ SELF%KLON = SELF%KLON_G SELF%KGPBLKS = SELF%KGPBLKS_G ! Does not work anymore with partial block ranges -!SELF%LFULL = SELF%KGPTOT_G == SELF%KGPTOT_S -SELF%LFULL = .FALSE. +SELF%LFULL = SELF%KGPTOT_G == SELF%KGPTOT_S +!SELF%LFULL = .FALSE. SELF%LNULL = SELF%KGPTOT_G == 0 IF (SELF%LNULL) THEN diff --git a/field_shuffle_type_module.fypp b/field_shuffle_type_module.fypp index 1e75d00..d482579 100644 --- a/field_shuffle_type_module.fypp +++ b/field_shuffle_type_module.fypp @@ -28,6 +28,7 @@ TYPE FIELD_SHUFFLE INTEGER (KIND=JPIM) :: KGPBLKS_G = -1, KLON_G = -1, KGPTOT_G = -1 INTEGER (KIND=JPIM) :: KGPBLKS_S = -1, KLON_S = -1, KGPTOT_S = -1 INTEGER (KIND=JPIM) :: KGPBLKS = -1, KLON = -1, KGPTOT = -1 ! alias for KGPBLKS, KLON, KGPTOT + INTEGER (KIND=JPIM) :: KBLKMIN, KBLKMAX LOGICAL :: LFULL = .FALSE. ! No need to gather/scatter, all columns are OK, return pointers based on original fields LOGICAL :: LNULL = .FALSE. ! No need to gather/scatter, all columns are KO, return pointers on empty arrays CLASS (FIELD_3IM), POINTER :: YLFINDS => NULL () @@ -74,6 +75,9 @@ SELF%KGPTOT = SELF%KGPTOT_G SELF%KLON = SELF%KLON_G SELF%KGPBLKS = SELF%KGPBLKS_G +SELF%KBLKMIN = IBLKOFF +SELF%KBLKMAX = SELF%KGPBLKS+IBLKOFF-1 + CALL FIELD_NEW (SELF%YLFINDS, UBOUNDS=[2, SELF%KLON_G, SELF%KGPBLKS_G], PERSISTENT=.TRUE.) INDS => GET_HOST_DATA_RDWR (SELF%YLFINDS) From 8fc854f84622d45fb2eb382abbb3b28e75711712 Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Wed, 3 Apr 2024 09:31:58 +0000 Subject: [PATCH 7/8] Cleaning --- field_gathscat_type_module.fypp | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/field_gathscat_type_module.fypp b/field_gathscat_type_module.fypp index 3ff2cf4..d0bd208 100644 --- a/field_gathscat_type_module.fypp +++ b/field_gathscat_type_module.fypp @@ -46,7 +46,6 @@ INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: KBLKMIN, KBLKMAX LOGICAL, POINTER :: LLF (:,:) INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, I1S, I2S -INTEGER (KIND=JPIM) :: JBOFF LLF => GET_HOST_DATA_RDONLY (YDFCOND) @@ -63,12 +62,10 @@ SELF%KGPTOT_S = KGPTOT SELF%KGPTOT_G = 0 -JBOFF = LBOUND (LLF, 2)-1 - -DO JBLKS = 1, SELF%KGPBLKS_S +DO JBLKS = SELF%KBLKMIN, SELF%KBLKMAX I1S = 1 - I2S = MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - 1) * SELF%KLON_S) - SELF%KGPTOT_G = SELF%KGPTOT_G + COUNT (LLF (I1S:I2S,JBLKS+JBOFF)) + I2S = MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - SELF%KBLKMIN) * SELF%KLON_S) + SELF%KGPTOT_G = SELF%KGPTOT_G + COUNT (LLF (I1S:I2S,JBLKS)) ENDDO IF (PRESENT (KLON_G)) THEN @@ -101,14 +98,14 @@ ELSE JBLKG = 1 JLONG = 1 - DO JBLKS = 1, SELF%KGPBLKS_S - DO JLONS = 1, MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - 1) * SELF%KLON_S) - IF (LLF (JLONS, JBLKS+JBOFF)) THEN + DO JBLKS = SELF%KBLKMIN, SELF%KBLKMAX + DO JLONS = 1, MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - SELF%KBLKMIN) * SELF%KLON_S) + IF (LLF (JLONS, JBLKS)) THEN IF ((JLONG > SIZE (INDS, 2)) .OR. (JBLKG > SIZE (INDS, 3))) THEN CALL FIELD_ABORT ('INIT_FIELD_SHUFFLE: OUT OF BOUNDS') ENDIF INDS (NLONDIM, JLONG, JBLKG) = JLONS - INDS (NBLKDIM, JLONG, JBLKG) = JBLKS+JBOFF + INDS (NBLKDIM, JLONG, JBLKG) = JBLKS JLONG = JLONG + 1 IF (JLONG > SELF%KLON_G) THEN JLONG = 1 From d4255e8cb50c89492dd879731897823fa2e478ef Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Thu, 4 Apr 2024 14:34:18 +0000 Subject: [PATCH 8/8] Use explicit loops (array syntax not possible because of pointers) --- field_RANKSUFF_shuffle_module.fypp | 36 +++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 8 deletions(-) diff --git a/field_RANKSUFF_shuffle_module.fypp b/field_RANKSUFF_shuffle_module.fypp index 3acb044..bcb589c 100644 --- a/field_RANKSUFF_shuffle_module.fypp +++ b/field_RANKSUFF_shuffle_module.fypp @@ -144,22 +144,32 @@ ${ft.type}$, POINTER :: PTRS(${ft.shape}$) INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG -#:set dc = ', ' + (':, ' * (ft.rank-2)) +#:set ind = ', '.join (map (lambda i: "J" + str (i), range (2, ft.rank))) +#:if ft.rank > 2 +INTEGER (KIND=JPIM) :: ${ind}$ +#:set ind = ind + ', ' +#:endif #:if what == 'DEVICE' !$acc parallel loop gang present (PTRG, PTRS, KNDS) #:elif what == 'HOST' -!$OMP PARALLEL DO PRIVATE (JBLKG, JLONG, JBLKS, JLONS) +!$OMP PARALLEL DO PRIVATE (${ind}$JBLKG, JLONG, JBLKS, JLONS) #:endif DO JBLKG = 1, SIZE (KNDS, 3) #:if what == 'DEVICE' -!$acc loop vector private (JLONG, JBLKS, JLONS) +!$acc loop vector private (${ind}$JLONG, JBLKS, JLONS) #:endif DO JLONG = 1, SIZE (KNDS, 2) JLONS = KNDS (NLONDIM, JLONG, JBLKG) JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) IF (JLONS > 0) THEN - PTRG (JLONG${dc}$JBLKG) = PTRS (JLONS${dc}$JBLKS) +#:for i in reversed (range (2, ft.rank)) + DO J${i}$ = LBOUND (PTRG, ${i}$), UBOUND (PTRG, ${i}$) +#:endfor + PTRG (JLONG, ${ind}$JBLKG) = PTRS (JLONS, ${ind}$JBLKS) +#:for i in (range (2, ft.rank)) + ENDDO +#:endfor ENDIF ENDDO ENDDO @@ -224,22 +234,32 @@ ${ft.type}$, POINTER :: PTRS(${ft.shape}$) INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG -#:set dc = ', ' + (':, ' * (ft.rank-2)) +#:set ind = ', '.join (map (lambda i: "J" + str (i), range (2, ft.rank))) +#:if ft.rank > 2 +INTEGER (KIND=JPIM) :: ${ind}$ +#:set ind = ind + ', ' +#:endif #:if what == 'DEVICE' !$acc parallel loop gang present (PTRG, PTRS, KNDS) #:elif what == 'HOST' -!$OMP PARALLEL DO PRIVATE (JBLKG, JLONG, JBLKS, JLONS) +!$OMP PARALLEL DO PRIVATE (${ind}$JBLKG, JLONG, JBLKS, JLONS) #:endif DO JBLKG = 1, SIZE (KNDS, 3) #:if what == 'DEVICE' -!$acc loop vector private (JLONG, JBLKS, JLONS) +!$acc loop vector private (${ind}$JLONG, JBLKS, JLONS) #:endif DO JLONG = 1, SIZE (KNDS, 2) JLONS = KNDS (NLONDIM, JLONG, JBLKG) JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) IF (JLONS > 0) THEN - PTRS (JLONS${dc}$JBLKS) = PTRG (JLONG${dc}$JBLKG) +#:for i in reversed (range (2, ft.rank)) + DO J${i}$ = LBOUND (PTRG, ${i}$), UBOUND (PTRG, ${i}$) +#:endfor + PTRS (JLONS, ${ind}$JBLKS) = PTRG (JLONG, ${ind}$JBLKG) +#:for i in (range (2, ft.rank)) + ENDDO +#:endfor ENDIF ENDDO ENDDO