From e37907d40cc8a80e4244d3ac8aa37280155f78e6 Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Mon, 29 Jun 2026 13:15:35 +0000 Subject: [PATCH 1/8] Add gather/scatter with collapse --- src/shuffle/CMakeLists.txt | 4 +- ...ield_RANKSUFF_gather_collapse2_module.fypp | 82 +++++ ...eld_RANKSUFF_shuffle_collapse2_module.fypp | 286 ++++++++++++++++++ .../field_gathscat_collapse2_module.fypp | 57 ++++ .../field_gathscat_collapse2_type_module.fypp | 182 +++++++++++ tests/CMakeLists.txt | 1 + tests/gather_scatter_collapse2.F90 | 106 +++++++ 7 files changed, 716 insertions(+), 2 deletions(-) create mode 100644 src/shuffle/field_RANKSUFF_gather_collapse2_module.fypp create mode 100644 src/shuffle/field_RANKSUFF_shuffle_collapse2_module.fypp create mode 100644 src/shuffle/field_gathscat_collapse2_module.fypp create mode 100644 src/shuffle/field_gathscat_collapse2_type_module.fypp create mode 100644 tests/gather_scatter_collapse2.F90 diff --git a/src/shuffle/CMakeLists.txt b/src/shuffle/CMakeLists.txt index 37ecb1e2..b24641db 100644 --- a/src/shuffle/CMakeLists.txt +++ b/src/shuffle/CMakeLists.txt @@ -8,8 +8,8 @@ # nor does it submit to any jurisdiction. -list( APPEND ranksuff_srcs _shuffle _gather) -list( APPEND non_ranksuff_srcs field_shuffle_module field_shuffle_type_module field_gathscat_module field_gathscat_type_module) +list( APPEND ranksuff_srcs _shuffle _gather _shuffle_collapse2 _gather_collapse2) +list( APPEND non_ranksuff_srcs field_shuffle_module field_shuffle_type_module field_gathscat_module field_gathscat_type_module field_gathscat_collapse2_module field_gathscat_collapse2_type_module) ## expand ranksuff sources diff --git a/src/shuffle/field_RANKSUFF_gather_collapse2_module.fypp b/src/shuffle/field_RANKSUFF_gather_collapse2_module.fypp new file mode 100644 index 00000000..415cf651 --- /dev/null +++ b/src/shuffle/field_RANKSUFF_gather_collapse2_module.fypp @@ -0,0 +1,82 @@ +#! (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_${RANK}$${SUFF}$_GATHER_COLLAPSE2_MODULE + +#:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + str (SUFF)], hasView=True) + +USE FIELD_${RANK}$${SUFF}$_MODULE +USE FIELD_${RANK}$${SUFF}$_ACCESS_MODULE +USE FIELD_${RANK}$${SUFF}$_FACTORY_MODULE +USE FIELD_GATHSCAT_COLLAPSE2_TYPE_MODULE +USE FIELD_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE2_MODULE +${fieldType.useParkind1 ()}$ + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: FIELD_GATHSCAT_COLLAPSE2 + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +#:for ft in fieldTypeList +#:if ft.rank >= 3 + +PUBLIC :: ${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ +PUBLIC :: S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ + +#:endif +#:endfor + +#:endfor +#:endfor + +CONTAINS + +#:for ft in fieldTypeList +#:if ft.rank >= 3 + +#:set collapsed_rank = ft.rank - 1 +#:set collapsed_shape = ','.join([':'] * collapsed_rank) + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +FUNCTION ${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (SELF, YLF) RESULT (PTR) + +CLASS (FIELD_GATHSCAT_COLLAPSE2) :: SELF +CLASS (${ft.name}$), POINTER, INTENT (IN) :: YLF + +${ft.type}$, POINTER :: PTR(${collapsed_shape}$) + +CALL S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (SELF, PTR, YLF) + +END FUNCTION ${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ + +SUBROUTINE S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (SELF, PTR, YLF) + +CLASS (FIELD_GATHSCAT_COLLAPSE2) :: SELF +${ft.type}$, POINTER :: PTR(${collapsed_shape}$) +CLASS (${ft.name}$), POINTER, OPTIONAL :: YLF + + +CALL PAIR_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (SELF%${ft.name}$_C2LIST, SELF%LNULL, & +& SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, PTR, YLF, SELF%KBLKMIN, SELF%KBLKMAX) + +END SUBROUTINE S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ + +#:endfor +#:endfor + +#:endif +#:endfor + +END MODULE FIELD_${RANK}$${SUFF}$_GATHER_COLLAPSE2_MODULE diff --git a/src/shuffle/field_RANKSUFF_shuffle_collapse2_module.fypp b/src/shuffle/field_RANKSUFF_shuffle_collapse2_module.fypp new file mode 100644 index 00000000..28984e09 --- /dev/null +++ b/src/shuffle/field_RANKSUFF_shuffle_collapse2_module.fypp @@ -0,0 +1,286 @@ +#! (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_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE2_MODULE + +#:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + SUFF], hasView=True) + +USE FIELD_${RANK}$${SUFF}$_MODULE +USE FIELD_${RANK}$${SUFF}$_ACCESS_MODULE +USE FIELD_${RANK}$${SUFF}$_FACTORY_MODULE + +#:for ft in fieldTypeList +#:if ft.rank >= 3 +#:set gathered_name = ft.name.replace(str(ft.rank), str(ft.rank - 1)) +USE ${gathered_name}$_MODULE +USE ${gathered_name}$_ACCESS_MODULE +USE ${gathered_name}$_FACTORY_MODULE +#:endif +#:endfor + +${fieldType.useParkind1 ()}$ + +IMPLICIT NONE + +PRIVATE + +#:for ft in fieldTypeList +#:if ft.rank >= 3 + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +INTERFACE PAIR_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ + MODULE PROCEDURE :: PAIR_${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ +END INTERFACE PAIR_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ + +PUBLIC :: PAIR_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ + +#:endfor +#:endfor + +INTERFACE PAIR_SCATTER_COLLAPSE2_DATA + MODULE PROCEDURE :: PAIR_${ft.name}$_SCATTER_COLLAPSE2_DATA +END INTERFACE PAIR_SCATTER_COLLAPSE2_DATA + +PUBLIC :: PAIR_SCATTER_COLLAPSE2_DATA + +TYPE ${ft.name}$_SHUFFLE_PAIR_COLLAPSE2 + INTEGER (KIND=JPIM) :: IMODE = -1 + INTEGER (KIND=JPIM) :: IWHAT = -1 + CLASS (${ft.name}$), POINTER :: YLSCAT => NULL () + CLASS (${gathered_name}$), POINTER :: YLGATH => NULL () + TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: NEXT => NULL () +END TYPE ${ft.name}$_SHUFFLE_PAIR_COLLAPSE2 + +PUBLIC :: ${ft.name}$_SHUFFLE_PAIR_COLLAPSE2 + +#:endif +#:endfor + +INTEGER (KIND=JPIM), PARAMETER :: NRDWR = 0, NRDONLY = 1, NHOST = 2, NDEVICE = 3 +INTEGER (KIND=JPIM), PARAMETER :: NLONDIM = 1, NLEVDIM = 2, NBLKDIM = 3 + +CONTAINS + +#:for ft in fieldTypeList +#:if ft.rank >= 3 + +#:set collapsed_rank = ft.rank - 1 +#:set collapsed_shape = ','.join([':'] * collapsed_rank) +#:set gathered_name = ft.name.replace(str(ft.rank), str(ft.rank - 1)) +#:set ind_list = list(map(lambda i: "J" + str(i), range(3, ft.rank))) +#:set ind_str = ', '.join(ind_list) +#:if len(ind_list) > 0 +#:set ind_str_comma = ind_str + ', ' +#:else +#:set ind_str_comma = '' +#:endif + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +SUBROUTINE PAIR_${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (YDPAIR, LDNULL, KLON, KGPBLKS, YDFINDS, PTR, YLF, KBLKMIN, KBLKMAX) + +USE FIELD_3IM_MODULE +USE FIELD_3IM_ACCESS_MODULE +USE FIELD_3IM_FACTORY_MODULE + +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: YDPAIR +LOGICAL, INTENT (IN) :: LDNULL +INTEGER (KIND=JPIM), INTENT (IN) :: KLON, KGPBLKS +CLASS (FIELD_3IM), POINTER :: YDFINDS +${ft.type}$, POINTER :: PTR(${collapsed_shape}$) +CLASS (${ft.name}$), POINTER, OPTIONAL :: YLF +INTEGER (KIND=JPIM), INTENT (IN) :: KBLKMIN +INTEGER (KIND=JPIM), INTENT (IN) :: KBLKMAX + +${ft.type}$, POINTER :: ZTRG(${collapsed_shape}$), ZTRS(${ft.shape}$) +${ft.type}$, POINTER :: ZSRC(${ft.shape}$) +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: YLPAIR +CLASS (${gathered_name}$), POINTER :: YLGATH_DUMM +INTEGER (KIND=JPIM) :: ILBOUNDS (${collapsed_rank}$), IUBOUNDS (${collapsed_rank}$) +INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) + +IF (LDNULL) THEN + + ! Return dummy pointer + YLGATH_DUMM => NULL () + PTR => GET_${what}$_DATA_${mode}$ (YLGATH_DUMM) + +ELSE + + ZSRC => GET_${what}$_DATA_RDONLY (YLF) + + ALLOCATE (YLPAIR) + YLPAIR%IMODE = N${mode}$ + YLPAIR%IWHAT = N${what}$ + YLPAIR%NEXT => YDPAIR + YDPAIR => YLPAIR + YLPAIR%YLSCAT => YLF + + ILBOUNDS (1) = 1 + IUBOUNDS (1) = KLON + +#:for i in range(3, ft.rank) + ILBOUNDS (${i - 1}$) = LBOUND (ZSRC, ${i}$) + IUBOUNDS (${i - 1}$) = UBOUND (ZSRC, ${i}$) +#:endfor + + ILBOUNDS (${collapsed_rank}$) = 1 + IUBOUNDS (${collapsed_rank}$) = KGPBLKS + + CALL FIELD_NEW (YLPAIR%YLGATH, LBOUNDS=ILBOUNDS, UBOUNDS=IUBOUNDS, PERSISTENT=.TRUE.) + + INDS => GET_${what}$_DATA_RDONLY (YDFINDS) + ZTRS => GET_${what}$_DATA_RDONLY (YLPAIR%YLSCAT) + ZTRG => GET_${what}$_DATA_RDWR (YLPAIR%YLGATH) + + CALL PAIR_${ft.name}$_COLLAPSE2_${what}$_${mode}$ (INDS) + + ! Return pointer on packed array + PTR => GET_${what}$_DATA_${mode}$ (YLPAIR%YLGATH) + +ENDIF + + +CONTAINS + +SUBROUTINE PAIR_${ft.name}$_COLLAPSE2_${what}$_${mode}$ (KNDS) + +INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) +INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, JLEVS + +#:if len(ind_list) > 0 +INTEGER (KIND=JPIM) :: ${ind_str}$ +#:endif + +#:if what == 'DEVICE' +$:offload_macros.parallel_gang_loop(present=['ZTRG', 'ZTRS', 'KNDS']) +#:elif what == 'HOST' +!$OMP PARALLEL DO PRIVATE (${ind_str_comma}$JBLKG, JLONG, JBLKS, JLONS, JLEVS) +#:endif +DO JBLKG = 1, SIZE (KNDS, 3) +#:if what == 'DEVICE' +$:offload_macros.parallel_vector_loop(private=['JLONG', 'JBLKS', 'JLONS', 'JLEVS']) +#:endif + DO JLONG = 1, SIZE (KNDS, 2) + JLONS = KNDS (NLONDIM, JLONG, JBLKG) + JLEVS = KNDS (NLEVDIM, JLONG, JBLKG) + JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) + IF (JLONS > 0) THEN +#:for i in range(3, ft.rank) + DO J${i}$ = LBOUND (ZTRG, ${i - 1}$), UBOUND (ZTRG, ${i - 1}$) +#:endfor + ZTRG (JLONG, ${ind_str_comma}$JBLKG) = ZTRS (JLONS, JLEVS, ${ind_str_comma}$JBLKS) +#:for i in reversed(range(3, ft.rank)) + ENDDO +#:endfor + ENDIF + ENDDO +ENDDO + +END SUBROUTINE + +END SUBROUTINE PAIR_${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ + +#:endfor +#:endfor + +SUBROUTINE PAIR_${ft.name}$_SCATTER_COLLAPSE2_DATA (YDPAIR, YDFINDS) + +USE FIELD_3IM_MODULE +USE FIELD_3IM_ACCESS_MODULE +USE FIELD_3IM_FACTORY_MODULE + +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: YDPAIR +CLASS (FIELD_3IM), POINTER :: YDFINDS + +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: YLPAIR +${ft.type}$, POINTER :: PTRG(${collapsed_shape}$), PTRS(${ft.shape}$) +INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) + +DO WHILE (ASSOCIATED (YDPAIR)) + + YLPAIR => YDPAIR%NEXT + + ! Scatter back results + IF (YDPAIR%IMODE == NRDWR) THEN + IF (YDPAIR%IWHAT == NDEVICE) THEN + + INDS => GET_DEVICE_DATA_RDONLY (YDFINDS) + PTRG => GET_DEVICE_DATA_RDONLY (YDPAIR%YLGATH) + PTRS => GET_DEVICE_DATA_RDWR (YDPAIR%YLSCAT) + + CALL ${ft.name}$_SCATTER_COLLAPSE2_DEVICE_KERNEL (INDS) + + ELSEIF (YDPAIR%IWHAT == NHOST) THEN + + INDS => GET_HOST_DATA_RDONLY (YDFINDS) + PTRG => GET_HOST_DATA_RDONLY (YDPAIR%YLGATH) + PTRS => GET_HOST_DATA_RDWR (YDPAIR%YLSCAT) + + CALL ${ft.name}$_SCATTER_COLLAPSE2_HOST_KERNEL (INDS) + + ENDIF + ENDIF + + CALL FIELD_DELETE (YDPAIR%YLGATH) + DEALLOCATE (YDPAIR) + NULLIFY (YDPAIR) + + YDPAIR => YLPAIR +ENDDO + +CONTAINS + +#:for what in ['DEVICE', 'HOST'] +SUBROUTINE ${ft.name}$_SCATTER_COLLAPSE2_${what}$_KERNEL (KNDS) + +INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) +INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, JLEVS + +#:if len(ind_list) > 0 +INTEGER (KIND=JPIM) :: ${ind_str}$ +#:endif + +#:if what == 'DEVICE' +$:offload_macros.parallel_gang_loop(present=['PTRG', 'PTRS', 'KNDS']) +#:elif what == 'HOST' +!$OMP PARALLEL DO PRIVATE (${ind_str_comma}$JBLKG, JLONG, JBLKS, JLONS, JLEVS) +#:endif +DO JBLKG = 1, SIZE (KNDS, 3) +#:if what == 'DEVICE' +$:offload_macros.parallel_vector_loop(private=['JLONG', 'JBLKS', 'JLONS', 'JLEVS']) +#:endif + DO JLONG = 1, SIZE (KNDS, 2) + JLONS = KNDS (NLONDIM, JLONG, JBLKG) + JLEVS = KNDS (NLEVDIM, JLONG, JBLKG) + JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) + IF (JLONS > 0) THEN +#:for i in range(3, ft.rank) + DO J${i}$ = LBOUND (PTRG, ${i - 1}$), UBOUND (PTRG, ${i - 1}$) +#:endfor + PTRS (JLONS, JLEVS, ${ind_str_comma}$JBLKS) = PTRG (JLONG, ${ind_str_comma}$JBLKG) +#:for i in reversed(range(3, ft.rank)) + ENDDO +#:endfor + ENDIF + ENDDO +ENDDO + +END SUBROUTINE + +#:endfor +END SUBROUTINE PAIR_${ft.name}$_SCATTER_COLLAPSE2_DATA + +#:endif +#:endfor + +END MODULE FIELD_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE2_MODULE diff --git a/src/shuffle/field_gathscat_collapse2_module.fypp b/src/shuffle/field_gathscat_collapse2_module.fypp new file mode 100644 index 00000000..e817ba25 --- /dev/null +++ b/src/shuffle/field_gathscat_collapse2_module.fypp @@ -0,0 +1,57 @@ +#! (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_GATHSCAT_COLLAPSE2_MODULE + +#:set fieldTypeList = fieldType.getFieldTypeList (hasView=True) + +USE FIELD_ACCESS_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_GATHSCAT_COLLAPSE2_TYPE_MODULE +${fieldType.useParkind1 ()}$ + +#:for ft in fieldTypeList +USE ${ft.name}$_GATHER_COLLAPSE2_MODULE +#:endfor + + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: FIELD_GATHSCAT_COLLAPSE2 + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +INTERFACE GATHER_${what}$_DATA_${mode}$ +#:for ft in fieldTypeList +#:if ft.rank >= 3 + MODULE PROCEDURE ${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ +#:endif +#:endfor +END INTERFACE GATHER_${what}$_DATA_${mode}$ + +PUBLIC :: GATHER_${what}$_DATA_${mode}$ + +INTERFACE SGATHER_${what}$_DATA_${mode}$ +#:for ft in fieldTypeList +#:if ft.rank >= 3 + MODULE PROCEDURE S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ +#:endif +#:endfor +END INTERFACE SGATHER_${what}$_DATA_${mode}$ + +PUBLIC :: SGATHER_${what}$_DATA_${mode}$ + +#:endfor +#:endfor + + +END MODULE FIELD_GATHSCAT_COLLAPSE2_MODULE diff --git a/src/shuffle/field_gathscat_collapse2_type_module.fypp b/src/shuffle/field_gathscat_collapse2_type_module.fypp new file mode 100644 index 00000000..743d1385 --- /dev/null +++ b/src/shuffle/field_gathscat_collapse2_type_module.fypp @@ -0,0 +1,182 @@ +#! (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_GATHSCAT_COLLAPSE2_TYPE_MODULE + +#:set fieldTypeList = fieldType.getFieldTypeList (hasView=True) + +USE FIELD_3LM_MODULE, ONLY : FIELD_3LM +USE FIELD_ACCESS_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_SHUFFLE_TYPE_MODULE +${fieldType.useParkind1 ()}$ + +#:for ft in fieldTypeList +#:if ft.rank >= 3 +USE ${ft.name}$_SHUFFLE_COLLAPSE2_MODULE +#:endif +#:endfor + +IMPLICIT NONE + +PRIVATE + +TYPE, EXTENDS (FIELD_SHUFFLE) :: FIELD_GATHSCAT_COLLAPSE2 +#:for ft in fieldTypeList +#:if ft.rank >= 3 + TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: ${ft.name}$_C2LIST => NULL () +#:endif +#:endfor +CONTAINS + GENERIC :: INIT => INIT_FIELD_GATHSCAT_COLLAPSE2 + PROCEDURE :: INIT_FIELD_GATHSCAT_COLLAPSE2 + PROCEDURE :: SCATTER => SCATTER_FIELD_GATHSCAT_COLLAPSE2 +END TYPE FIELD_GATHSCAT_COLLAPSE2 + +PUBLIC :: FIELD_GATHSCAT_COLLAPSE2 + +INTEGER (KIND=JPIM), PARAMETER :: NLONDIM = 1, NLEVDIM = 2, NBLKDIM = 3 + +CONTAINS + +SUBROUTINE INIT_FIELD_GATHSCAT_COLLAPSE2 (SELF, YDFCOND, KGPTOT, KLON_G, KBLKMIN, KBLKMAX) + +USE FIELD_ABORT_MODULE + +CLASS (FIELD_GATHSCAT_COLLAPSE2) :: SELF +CLASS (FIELD_3LM), POINTER :: YDFCOND +INTEGER (KIND=JPIM), INTENT (IN) :: KGPTOT +INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: 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, JLEV + +LLF => GET_HOST_DATA_RDONLY (YDFCOND) + +SELF%KBLKMIN = LBOUND (LLF, 3) +IF (PRESENT (KBLKMIN)) SELF%KBLKMIN = KBLKMIN +SELF%KBLKMAX = UBOUND (LLF, 3) +IF (PRESENT (KBLKMAX)) SELF%KBLKMAX = KBLKMAX + +SELF%KLON_S = SIZE (LLF, 1) +SELF%KGPBLKS_S = SELF%KBLKMAX - SELF%KBLKMIN + 1 +SELF%KGPTOT_S = KGPTOT + +! Reduction: count active (JLON, JLEV) pairs + +SELF%KGPTOT_G = 0 + +DO JBLKS = SELF%KBLKMIN, SELF%KBLKMAX + I1S = 1 + I2S = MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - SELF%KBLKMIN) * SELF%KLON_S) + DO JLEV = LBOUND (LLF, 2), UBOUND (LLF, 2) + SELF%KGPTOT_G = SELF%KGPTOT_G + COUNT (LLF (I1S:I2S, JLEV, JBLKS)) + ENDDO +ENDDO + +IF (PRESENT (KLON_G)) THEN + SELF%KLON_G = KLON_G +ELSE + SELF%KLON_G = SELF%KLON_S +ENDIF + +SELF%KGPBLKS_G = (SELF%KGPTOT_G+SELF%KLON_G-1) / SELF%KLON_G + +SELF%KGPTOT = SELF%KGPTOT_G +SELF%KLON = SELF%KLON_G +SELF%KGPBLKS = SELF%KGPBLKS_G + +! For COLLAPSE2, we cannot avoid gather even when all points are active +! because the gathered array has a different rank (collapsed). +SELF%LFULL = .FALSE. +SELF%LNULL = SELF%KGPTOT_G == 0 + +IF (SELF%LNULL) THEN + ! Do nothing +ELSE + + CALL FIELD_NEW (SELF%YLFINDS, UBOUNDS=[3, SELF%KLON_G, SELF%KGPBLKS_G], PERSISTENT=.TRUE.) + INDS => GET_HOST_DATA_RDWR (SELF%YLFINDS) + + ! Create indices (serial code) + + JBLKG = 1 + JLONG = 1 + DO JBLKS = SELF%KBLKMIN, SELF%KBLKMAX + DO JLEV = LBOUND (LLF, 2), UBOUND (LLF, 2) + DO JLONS = 1, MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - SELF%KBLKMIN) * SELF%KLON_S) + IF (LLF (JLONS, JLEV, JBLKS)) THEN + IF ((JLONG > SIZE (INDS, 2)) .OR. (JBLKG > SIZE (INDS, 3))) THEN + CALL FIELD_ABORT ('INIT_FIELD_GATHSCAT_COLLAPSE2: OUT OF BOUNDS') + ENDIF + INDS (NLONDIM, JLONG, JBLKG) = JLONS + INDS (NLEVDIM, JLONG, JBLKG) = JLEV + INDS (NBLKDIM, JLONG, JBLKG) = JBLKS + JLONG = JLONG + 1 + IF (JLONG > SELF%KLON_G) THEN + JLONG = 1 + JBLKG = JBLKG + 1 + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + + IF (JBLKG <= SIZE (INDS, 3)) THEN + DO WHILE (JLONG <= SELF%KLON_G) + INDS (NLONDIM, JLONG, JBLKG) = -9999999 + INDS (NLEVDIM, JLONG, JBLKG) = -9999999 + INDS (NBLKDIM, JLONG, JBLKG) = -9999999 + JLONG = JLONG + 1 + ENDDO + ENDIF + +ENDIF + +END SUBROUTINE + +SUBROUTINE SCATTER_FIELD_GATHSCAT_COLLAPSE2 (SELF) +CLASS (FIELD_GATHSCAT_COLLAPSE2) :: SELF +#:for ft in fieldTypeList +#:if ft.rank >= 3 +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: ${ft.name}$_C2LIST +#:endif +#:endfor + +IF (SELF%LNULL) THEN + ! Do nothing +ELSE + +#:for ft in fieldTypeList +#:if ft.rank >= 3 + CALL PAIR_SCATTER_COLLAPSE2_DATA (SELF%${ft.name}$_C2LIST, SELF%YLFINDS) +#:endif +#:endfor + + CALL FIELD_DELETE (SELF%YLFINDS) + +ENDIF + +SELF%YLFINDS => NULL () +SELF%KGPBLKS_G = -1 +SELF%KLON_G = -1 +SELF%KGPTOT_G = -1 +SELF%KGPBLKS_S = -1 +SELF%KLON_S = -1 +SELF%KGPTOT_S = -1 + +SELF%KGPTOT = -1 +SELF%KLON = -1 +SELF%KGPBLKS = -1 + +END SUBROUTINE + +END MODULE FIELD_GATHSCAT_COLLAPSE2_TYPE_MODULE diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index d44622e6..ed8bc8ff 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -51,6 +51,7 @@ list(APPEND TEST_FILES final_wrapper_gpu.F90 gather_scatter.F90 gather_scatter_lastdim.F90 + gather_scatter_collapse2.F90 get_dims.F90 get_stats.F90 get_view.F90 diff --git a/tests/gather_scatter_collapse2.F90 b/tests/gather_scatter_collapse2.F90 new file mode 100644 index 00000000..c2c8045f --- /dev/null +++ b/tests/gather_scatter_collapse2.F90 @@ -0,0 +1,106 @@ +PROGRAM GATHER_SCATTER_COLLAPSE2 + +USE FIELD_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_ACCESS_MODULE +USE FIELD_GATHSCAT_COLLAPSE2_MODULE +USE PARKIND1 +USE FIELD_ABORT_MODULE +IMPLICIT NONE + +TYPE(FIELD_GATHSCAT_COLLAPSE2):: FGS +CLASS(FIELD_3LM), POINTER :: FTRIG => NULL() +INTEGER, PARAMETER :: NPROMA = 10, NGPBLKS = 4, NFLEVG = 10, NFLD = 5 +LOGICAL :: TRIG(NPROMA,NFLEVG,NGPBLKS) +INTEGER ::JLON,JBLK,JLEV,JFLD,IIDIA, IFDIA +INTEGER :: NGPTOT + +INTEGER(KIND=JPIM), ALLOCATABLE :: D(:,:,:,:) +CLASS(FIELD_4IM),POINTER :: FD => NULL() +INTEGER(KIND=JPIM),POINTER :: FILTERED_D(:,:,:) => NULL() + +INTEGER :: FUNC +INTEGER, PARAMETER :: IMISS = -99999 + +FUNC (JLON, JLEV, JFLD, JBLK) = (JBLK-1) * NPROMA + (JLON-1) + NGPTOT * (JLEV-1 + NFLEVG * (JFLD-1)) + +NGPTOT = NPROMA * NGPBLKS - 4 + +TRIG=.FALSE. + +DO JBLK = 1, NGPBLKS + IIDIA = 1 + IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) + DO JLEV = 1, NFLEVG + DO JLON=1,NPROMA + TRIG(JLON,JLEV,JBLK) = MOD (JLON+JLEV, 2) == 0 + ENDDO + ENDDO +ENDDO + +CALL FIELD_NEW (FTRIG, DATA=TRIG) + +ALLOCATE(D (NPROMA, NFLEVG, NFLD, NGPBLKS)) + +DO JBLK = 1, NGPBLKS + IIDIA = 1 + IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) + DO JFLD = 1, NFLD + DO JLEV = 1, NFLEVG + DO JLON = IIDIA, IFDIA + D (JLON, JLEV, JFLD, JBLK) = 1 + ENDDO + DO JLON = IFDIA+1, NPROMA + D (JLON, JLEV, JFLD, JBLK) = IMISS + ENDDO + ENDDO + ENDDO +ENDDO + +CALL FIELD_NEW (FD, DATA=D) + +CALL FGS%INIT (FTRIG, NGPTOT) +FILTERED_D => GATHER_HOST_DATA_RDWR (FGS, FD) + +DO JBLK = 1, FGS%KGPBLKS + IIDIA = 1 + IFDIA = MERGE (FGS%KLON, FGS%KGPTOT - (JBLK - 1) * FGS%KLON, JBLK < FGS%KGPBLKS) + DO JFLD = 1, NFLD + DO JLON = IIDIA, IFDIA + FILTERED_D (JLON, JFLD, JBLK) = 2 + ENDDO + DO JLON = IFDIA+1, FGS%KLON + FILTERED_D (JLON, JFLD, JBLK) = IMISS + ENDDO + ENDDO +ENDDO + +CALL FGS%SCATTER () + +DO JBLK = 1, NGPBLKS + IIDIA = 1 + IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) + + DO JFLD = 1, NFLD + DO JLEV = 1, NFLEVG + + DO JLON = IIDIA, IFDIA + IF (MOD (JLON+JLEV, 2) == 0) THEN + IF (D (JLON, JLEV, JFLD, JBLK) /= 2) CALL FIELD_ABORT ("ERROR") + ELSE + IF (D (JLON, JLEV, JFLD, JBLK) /= 1) CALL FIELD_ABORT ("ERROR") + ENDIF + ENDDO + + DO JLON = IFDIA+1, NPROMA + IF (D (JLON, JLEV, JFLD, JBLK) /= IMISS) CALL FIELD_ABORT ("ERROR") + ENDDO + + ENDDO + ENDDO + +ENDDO + +CALL FIELD_DELETE(FTRIG) + +END PROGRAM From fbb59c261bf7d2b5bdaae9db456f543569340c12 Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Mon, 29 Jun 2026 13:47:01 +0000 Subject: [PATCH 2/8] Cleaning --- tests/gather_scatter_collapse2.F90 | 72 ++++++++++++++++-------------- 1 file changed, 39 insertions(+), 33 deletions(-) diff --git a/tests/gather_scatter_collapse2.F90 b/tests/gather_scatter_collapse2.F90 index c2c8045f..2124d2de 100644 --- a/tests/gather_scatter_collapse2.F90 +++ b/tests/gather_scatter_collapse2.F90 @@ -6,41 +6,44 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 USE FIELD_GATHSCAT_COLLAPSE2_MODULE USE PARKIND1 USE FIELD_ABORT_MODULE + IMPLICIT NONE -TYPE(FIELD_GATHSCAT_COLLAPSE2):: FGS -CLASS(FIELD_3LM), POINTER :: FTRIG => NULL() -INTEGER, PARAMETER :: NPROMA = 10, NGPBLKS = 4, NFLEVG = 10, NFLD = 5 -LOGICAL :: TRIG(NPROMA,NFLEVG,NGPBLKS) -INTEGER ::JLON,JBLK,JLEV,JFLD,IIDIA, IFDIA -INTEGER :: NGPTOT +INTEGER (KIND=JPIM), PARAMETER :: NPROMA = 10, NGPBLKS = 4, NFLEVG = 10, NFLD = 5, NGPTOT = NPROMA * NGPBLKS - 4 +INTEGER (KIND=JPIM), PARAMETER :: NMISS = -99999, NNEW = 22222 + +TYPE (FIELD_GATHSCAT_COLLAPSE2) :: YL_FGS + +LOGICAL :: LLTRIG (NPROMA, NFLEVG, NGPBLKS) +CLASS (FIELD_3LM), POINTER :: YLTRIG => NULL () + +INTEGER (KIND=JPIM), ALLOCATABLE :: ID (:,:,:,:) +CLASS (FIELD_4IM), POINTER :: YLFD => NULL() + +INTEGER (KIND=JPIM),POINTER :: ID_FILTERED (:,:,:) => NULL () -INTEGER(KIND=JPIM), ALLOCATABLE :: D(:,:,:,:) -CLASS(FIELD_4IM),POINTER :: FD => NULL() -INTEGER(KIND=JPIM),POINTER :: FILTERED_D(:,:,:) => NULL() +INTEGER (KIND=JPIM) :: JLON, JBLK, JLEV, JFLD, IIDIA, IFDIA -INTEGER :: FUNC -INTEGER, PARAMETER :: IMISS = -99999 +INTEGER (KIND=JPIM) :: FUNC FUNC (JLON, JLEV, JFLD, JBLK) = (JBLK-1) * NPROMA + (JLON-1) + NGPTOT * (JLEV-1 + NFLEVG * (JFLD-1)) -NGPTOT = NPROMA * NGPBLKS - 4 -TRIG=.FALSE. +LLTRIG=.FALSE. DO JBLK = 1, NGPBLKS IIDIA = 1 IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) DO JLEV = 1, NFLEVG - DO JLON=1,NPROMA - TRIG(JLON,JLEV,JBLK) = MOD (JLON+JLEV, 2) == 0 + DO JLON = IIDIA, IFDIA + LLTRIG (JLON,JLEV,JBLK) = MOD (JLON+JLEV, 2) == 0 ENDDO ENDDO ENDDO -CALL FIELD_NEW (FTRIG, DATA=TRIG) +CALL FIELD_NEW (YLTRIG, DATA=LLTRIG) -ALLOCATE(D (NPROMA, NFLEVG, NFLD, NGPBLKS)) +ALLOCATE(ID (NPROMA, NFLEVG, NFLD, NGPBLKS)) DO JBLK = 1, NGPBLKS IIDIA = 1 @@ -48,34 +51,34 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 DO JFLD = 1, NFLD DO JLEV = 1, NFLEVG DO JLON = IIDIA, IFDIA - D (JLON, JLEV, JFLD, JBLK) = 1 + ID (JLON, JLEV, JFLD, JBLK) = FUNC (JLON, JLEV, JFLD, JBLK) ENDDO DO JLON = IFDIA+1, NPROMA - D (JLON, JLEV, JFLD, JBLK) = IMISS + ID (JLON, JLEV, JFLD, JBLK) = NMISS ENDDO ENDDO ENDDO ENDDO -CALL FIELD_NEW (FD, DATA=D) +CALL FIELD_NEW (YLFD, DATA=ID) -CALL FGS%INIT (FTRIG, NGPTOT) -FILTERED_D => GATHER_HOST_DATA_RDWR (FGS, FD) +CALL YL_FGS%INIT (YLTRIG, NGPTOT) +ID_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFD) -DO JBLK = 1, FGS%KGPBLKS +DO JBLK = 1, YL_FGS%KGPBLKS IIDIA = 1 - IFDIA = MERGE (FGS%KLON, FGS%KGPTOT - (JBLK - 1) * FGS%KLON, JBLK < FGS%KGPBLKS) + IFDIA = MERGE (YL_FGS%KLON, YL_FGS%KGPTOT - (JBLK - 1) * YL_FGS%KLON, JBLK < YL_FGS%KGPBLKS) DO JFLD = 1, NFLD DO JLON = IIDIA, IFDIA - FILTERED_D (JLON, JFLD, JBLK) = 2 + ID_FILTERED (JLON, JFLD, JBLK) = NNEW ENDDO - DO JLON = IFDIA+1, FGS%KLON - FILTERED_D (JLON, JFLD, JBLK) = IMISS + DO JLON = IFDIA+1, YL_FGS%KLON + ID_FILTERED (JLON, JFLD, JBLK) = NMISS ENDDO ENDDO ENDDO -CALL FGS%SCATTER () +CALL YL_FGS%SCATTER () DO JBLK = 1, NGPBLKS IIDIA = 1 @@ -85,15 +88,18 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 DO JLEV = 1, NFLEVG DO JLON = IIDIA, IFDIA - IF (MOD (JLON+JLEV, 2) == 0) THEN - IF (D (JLON, JLEV, JFLD, JBLK) /= 2) CALL FIELD_ABORT ("ERROR") + IF (LLTRIG (JLON, JLEV, JBLK)) THEN + IF (ID (JLON, JLEV, JFLD, JBLK) /= NNEW) & + & CALL FIELD_ABORT ("ERROR") ELSE - IF (D (JLON, JLEV, JFLD, JBLK) /= 1) CALL FIELD_ABORT ("ERROR") + IF (ID (JLON, JLEV, JFLD, JBLK) /= FUNC (JLON, JLEV, JFLD, JBLK)) & + & CALL FIELD_ABORT ("ERROR") ENDIF ENDDO DO JLON = IFDIA+1, NPROMA - IF (D (JLON, JLEV, JFLD, JBLK) /= IMISS) CALL FIELD_ABORT ("ERROR") + IF (ID (JLON, JLEV, JFLD, JBLK) /= NMISS) & + & CALL FIELD_ABORT ("ERROR") ENDDO ENDDO @@ -101,6 +107,6 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 ENDDO -CALL FIELD_DELETE(FTRIG) +CALL FIELD_DELETE (YLTRIG) END PROGRAM From 469798c2503925990c09d9da0eb8bd8b6526b9e0 Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Mon, 29 Jun 2026 13:49:22 +0000 Subject: [PATCH 3/8] Cleaning --- tests/gather_scatter_collapse2.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/gather_scatter_collapse2.F90 b/tests/gather_scatter_collapse2.F90 index 2124d2de..f83268a1 100644 --- a/tests/gather_scatter_collapse2.F90 +++ b/tests/gather_scatter_collapse2.F90 @@ -29,7 +29,7 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 FUNC (JLON, JLEV, JFLD, JBLK) = (JBLK-1) * NPROMA + (JLON-1) + NGPTOT * (JLEV-1 + NFLEVG * (JFLD-1)) -LLTRIG=.FALSE. +LLTRIG = .FALSE. DO JBLK = 1, NGPBLKS IIDIA = 1 From 21f1f4e8aa0f0e8b19efb29392cff9d4ada24d3c Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Mon, 29 Jun 2026 14:25:22 +0000 Subject: [PATCH 4/8] Add collapse1 + more tests --- src/shuffle/CMakeLists.txt | 4 ++-- tests/CMakeLists.txt | 3 +++ 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/shuffle/CMakeLists.txt b/src/shuffle/CMakeLists.txt index b24641db..d8403fb0 100644 --- a/src/shuffle/CMakeLists.txt +++ b/src/shuffle/CMakeLists.txt @@ -8,8 +8,8 @@ # nor does it submit to any jurisdiction. -list( APPEND ranksuff_srcs _shuffle _gather _shuffle_collapse2 _gather_collapse2) -list( APPEND non_ranksuff_srcs field_shuffle_module field_shuffle_type_module field_gathscat_module field_gathscat_type_module field_gathscat_collapse2_module field_gathscat_collapse2_type_module) +list( APPEND ranksuff_srcs _shuffle _gather _shuffle_collapse1 _gather_collapse1 _shuffle_collapse2 _gather_collapse2) +list( APPEND non_ranksuff_srcs field_shuffle_module field_shuffle_type_module field_gathscat_module field_gathscat_type_module field_gathscat_collapse1_module field_gathscat_collapse1_type_module field_gathscat_collapse2_module field_gathscat_collapse2_type_module) ## expand ranksuff sources diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index ed8bc8ff..d5c7dd1b 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -51,7 +51,10 @@ list(APPEND TEST_FILES final_wrapper_gpu.F90 gather_scatter.F90 gather_scatter_lastdim.F90 + gather_scatter_collapse1.F90 + gather_scatter_collapse1_lastdim.F90 gather_scatter_collapse2.F90 + gather_scatter_collapse2_lastdim.F90 get_dims.F90 get_stats.F90 get_view.F90 From 2ddb91fdd4030b08a5c128172537c03877377ece Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Mon, 29 Jun 2026 19:16:37 +0000 Subject: [PATCH 5/8] Generate field_gathscat_collapse1 (identical to field_gathscat) from the same fypp used for COLLAPSE=2 --- cmake/field_api_get_lib_type.cmake | 1 + src/shuffle/CMakeLists.txt | 46 +- ...ield_RANKSUFF_gather_collapse2_module.fypp | 82 ---- ...NKSUFF_gather_collapseCOLLAPSE_module.fypp | 86 ++++ ...eld_RANKSUFF_shuffle_collapse2_module.fypp | 286 ------------- ...KSUFF_shuffle_collapseCOLLAPSE_module.fypp | 394 ++++++++++++++++++ ...eld_gathscat_collapseCOLLAPSE_module.fypp} | 20 +- ...athscat_collapseCOLLAPSE_type_module.fypp} | 99 +++-- tests/gather_scatter_collapse1.F90 | 106 +++++ tests/gather_scatter_collapse1_lastdim.F90 | 148 +++++++ tests/gather_scatter_collapse2.F90 | 55 ++- tests/gather_scatter_collapse2_lastdim.F90 | 147 +++++++ 12 files changed, 1057 insertions(+), 413 deletions(-) delete mode 100644 src/shuffle/field_RANKSUFF_gather_collapse2_module.fypp create mode 100644 src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp delete mode 100644 src/shuffle/field_RANKSUFF_shuffle_collapse2_module.fypp create mode 100644 src/shuffle/field_RANKSUFF_shuffle_collapseCOLLAPSE_module.fypp rename src/shuffle/{field_gathscat_collapse2_module.fypp => field_gathscat_collapseCOLLAPSE_module.fypp} (67%) rename src/shuffle/{field_gathscat_collapse2_type_module.fypp => field_gathscat_collapseCOLLAPSE_type_module.fypp} (56%) create mode 100644 tests/gather_scatter_collapse1.F90 create mode 100644 tests/gather_scatter_collapse1_lastdim.F90 create mode 100644 tests/gather_scatter_collapse2_lastdim.F90 diff --git a/cmake/field_api_get_lib_type.cmake b/cmake/field_api_get_lib_type.cmake index 90734408..06eb9b97 100644 --- a/cmake/field_api_get_lib_type.cmake +++ b/cmake/field_api_get_lib_type.cmake @@ -51,4 +51,5 @@ macro( field_api_get_lib_type ) endif() endif() + set( field_api_lib_type STATIC ) endmacro() diff --git a/src/shuffle/CMakeLists.txt b/src/shuffle/CMakeLists.txt index d8403fb0..7e7bfcf8 100644 --- a/src/shuffle/CMakeLists.txt +++ b/src/shuffle/CMakeLists.txt @@ -8,8 +8,8 @@ # nor does it submit to any jurisdiction. -list( APPEND ranksuff_srcs _shuffle _gather _shuffle_collapse1 _gather_collapse1 _shuffle_collapse2 _gather_collapse2) -list( APPEND non_ranksuff_srcs field_shuffle_module field_shuffle_type_module field_gathscat_module field_gathscat_type_module field_gathscat_collapse1_module field_gathscat_collapse1_type_module field_gathscat_collapse2_module field_gathscat_collapse2_type_module) +list( APPEND ranksuff_srcs _shuffle _gather) +list( APPEND non_ranksuff_srcs field_shuffle_module field_shuffle_type_module field_gathscat_module field_gathscat_type_module) ## expand ranksuff sources @@ -28,6 +28,48 @@ field_api_expand_fypp( OUTPUT_SRCS srcs ) +## expand unified collapse templates for COLLAPSE=1 and COLLAPSE=2 +foreach (SUFF IN ITEMS IM RM RD LM) + string (TOLOWER ${SUFF} suff) + foreach (RANK RANGE 1 5) + foreach (COLLAPSE IN ITEMS 1 2) + foreach (FUNC IN ITEMS _shuffle _gather) + add_custom_command ( + OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/field_${RANK}${suff}${FUNC}_collapse${COLLAPSE}_module.F90 + COMMAND ${FYPP} -DRANK=${RANK} -DSUFF='${SUFF}' -DCOLLAPSE=${COLLAPSE} ${fypp_defines} -m os -M ${PROJECT_SOURCE_DIR}/python_utils -m fieldType + -DOFFLOAD_MODEL="${FIELD_API_OFFLOAD_MODEL}" -M ${PROJECT_SOURCE_DIR}/python_utils -m offload_macros + ${CMAKE_CURRENT_SOURCE_DIR}/field_RANKSUFF${FUNC}_collapseCOLLAPSE_module.fypp + > ${CMAKE_CURRENT_BINARY_DIR}/field_${RANK}${suff}${FUNC}_collapse${COLLAPSE}_module.F90 + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/field_RANKSUFF${FUNC}_collapseCOLLAPSE_module.fypp + VERBATIM) + list(APPEND srcs ${CMAKE_CURRENT_BINARY_DIR}/field_${RANK}${suff}${FUNC}_collapse${COLLAPSE}_module.F90) + endforeach () + endforeach () + endforeach () +endforeach () + +foreach (COLLAPSE IN ITEMS 1 2) + add_custom_command ( + OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/field_gathscat_collapse${COLLAPSE}_module.F90 + COMMAND ${FYPP} -DCOLLAPSE=${COLLAPSE} ${fypp_defines} -m os -M ${PROJECT_SOURCE_DIR}/python_utils -m fieldType + -DOFFLOAD_MODEL="${FIELD_API_OFFLOAD_MODEL}" -M ${PROJECT_SOURCE_DIR}/python_utils -m offload_macros + ${CMAKE_CURRENT_SOURCE_DIR}/field_gathscat_collapseCOLLAPSE_module.fypp + > ${CMAKE_CURRENT_BINARY_DIR}/field_gathscat_collapse${COLLAPSE}_module.F90 + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/field_gathscat_collapseCOLLAPSE_module.fypp + VERBATIM) + list(APPEND srcs ${CMAKE_CURRENT_BINARY_DIR}/field_gathscat_collapse${COLLAPSE}_module.F90) + + add_custom_command ( + OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/field_gathscat_collapse${COLLAPSE}_type_module.F90 + COMMAND ${FYPP} -DCOLLAPSE=${COLLAPSE} ${fypp_defines} -m os -M ${PROJECT_SOURCE_DIR}/python_utils -m fieldType + -DOFFLOAD_MODEL="${FIELD_API_OFFLOAD_MODEL}" -M ${PROJECT_SOURCE_DIR}/python_utils -m offload_macros + ${CMAKE_CURRENT_SOURCE_DIR}/field_gathscat_collapseCOLLAPSE_type_module.fypp + > ${CMAKE_CURRENT_BINARY_DIR}/field_gathscat_collapse${COLLAPSE}_type_module.F90 + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/field_gathscat_collapseCOLLAPSE_type_module.fypp + VERBATIM) + list(APPEND srcs ${CMAKE_CURRENT_BINARY_DIR}/field_gathscat_collapse${COLLAPSE}_type_module.F90) +endforeach () + ## define object library field_api_add_object_library( LIBNAME field_api_shuffle diff --git a/src/shuffle/field_RANKSUFF_gather_collapse2_module.fypp b/src/shuffle/field_RANKSUFF_gather_collapse2_module.fypp deleted file mode 100644 index 415cf651..00000000 --- a/src/shuffle/field_RANKSUFF_gather_collapse2_module.fypp +++ /dev/null @@ -1,82 +0,0 @@ -#! (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_${RANK}$${SUFF}$_GATHER_COLLAPSE2_MODULE - -#:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + str (SUFF)], hasView=True) - -USE FIELD_${RANK}$${SUFF}$_MODULE -USE FIELD_${RANK}$${SUFF}$_ACCESS_MODULE -USE FIELD_${RANK}$${SUFF}$_FACTORY_MODULE -USE FIELD_GATHSCAT_COLLAPSE2_TYPE_MODULE -USE FIELD_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE2_MODULE -${fieldType.useParkind1 ()}$ - -IMPLICIT NONE - -PRIVATE - -PUBLIC :: FIELD_GATHSCAT_COLLAPSE2 - -#:for what in ['DEVICE', 'HOST'] -#:for mode in ['RDONLY', 'RDWR'] - -#:for ft in fieldTypeList -#:if ft.rank >= 3 - -PUBLIC :: ${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ -PUBLIC :: S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ - -#:endif -#:endfor - -#:endfor -#:endfor - -CONTAINS - -#:for ft in fieldTypeList -#:if ft.rank >= 3 - -#:set collapsed_rank = ft.rank - 1 -#:set collapsed_shape = ','.join([':'] * collapsed_rank) - -#:for what in ['DEVICE', 'HOST'] -#:for mode in ['RDONLY', 'RDWR'] - -FUNCTION ${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (SELF, YLF) RESULT (PTR) - -CLASS (FIELD_GATHSCAT_COLLAPSE2) :: SELF -CLASS (${ft.name}$), POINTER, INTENT (IN) :: YLF - -${ft.type}$, POINTER :: PTR(${collapsed_shape}$) - -CALL S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (SELF, PTR, YLF) - -END FUNCTION ${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ - -SUBROUTINE S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (SELF, PTR, YLF) - -CLASS (FIELD_GATHSCAT_COLLAPSE2) :: SELF -${ft.type}$, POINTER :: PTR(${collapsed_shape}$) -CLASS (${ft.name}$), POINTER, OPTIONAL :: YLF - - -CALL PAIR_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (SELF%${ft.name}$_C2LIST, SELF%LNULL, & -& SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, PTR, YLF, SELF%KBLKMIN, SELF%KBLKMAX) - -END SUBROUTINE S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ - -#:endfor -#:endfor - -#:endif -#:endfor - -END MODULE FIELD_${RANK}$${SUFF}$_GATHER_COLLAPSE2_MODULE diff --git a/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp b/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp new file mode 100644 index 00000000..7de95605 --- /dev/null +++ b/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp @@ -0,0 +1,86 @@ +#! (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_${RANK}$${SUFF}$_GATHER_COLLAPSE${COLLAPSE}$_MODULE + +#:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + str (SUFF)], hasView=True) + +USE FIELD_${RANK}$${SUFF}$_MODULE +USE FIELD_${RANK}$${SUFF}$_ACCESS_MODULE +USE FIELD_${RANK}$${SUFF}$_FACTORY_MODULE +USE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$_TYPE_MODULE +USE FIELD_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE${COLLAPSE}$_MODULE +${fieldType.useParkind1 ()}$ + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +#:for ft in fieldTypeList +#:if ft.rank >= COLLAPSE + 1 + +PUBLIC :: ${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ +PUBLIC :: S${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ + +#:endif +#:endfor + +#:endfor +#:endfor + +CONTAINS + +#:for ft in fieldTypeList +#:if ft.rank >= COLLAPSE + 1 + +#:if COLLAPSE == 1 +#:set gathered_shape = ft.shape +#:elif COLLAPSE == 2 +#:set gathered_rank = ft.rank - 1 +#:set gathered_shape = ','.join([':'] * gathered_rank) +#:endif + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +FUNCTION ${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ (SELF, YLF) RESULT (PTR) + +CLASS (FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$) :: SELF +CLASS (${ft.name}$), POINTER, INTENT (IN) :: YLF + +${ft.type}$, POINTER :: PTR(${gathered_shape}$) + +CALL S${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ (SELF, PTR, YLF) + +END FUNCTION ${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ + +SUBROUTINE S${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ (SELF, PTR, YLF) + +CLASS (FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$) :: SELF +${ft.type}$, POINTER :: PTR(${gathered_shape}$) +CLASS (${ft.name}$), POINTER, OPTIONAL :: YLF + + +CALL PAIR_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ (SELF%${ft.name}$_C${COLLAPSE}$LIST, SELF%LNULL, SELF%LFULL, & +& SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, PTR, YLF, SELF%KBLKMIN, SELF%KBLKMAX) + +END SUBROUTINE S${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ + +#:endfor +#:endfor + +#:endif +#:endfor + +END MODULE FIELD_${RANK}$${SUFF}$_GATHER_COLLAPSE${COLLAPSE}$_MODULE diff --git a/src/shuffle/field_RANKSUFF_shuffle_collapse2_module.fypp b/src/shuffle/field_RANKSUFF_shuffle_collapse2_module.fypp deleted file mode 100644 index 28984e09..00000000 --- a/src/shuffle/field_RANKSUFF_shuffle_collapse2_module.fypp +++ /dev/null @@ -1,286 +0,0 @@ -#! (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_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE2_MODULE - -#:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + SUFF], hasView=True) - -USE FIELD_${RANK}$${SUFF}$_MODULE -USE FIELD_${RANK}$${SUFF}$_ACCESS_MODULE -USE FIELD_${RANK}$${SUFF}$_FACTORY_MODULE - -#:for ft in fieldTypeList -#:if ft.rank >= 3 -#:set gathered_name = ft.name.replace(str(ft.rank), str(ft.rank - 1)) -USE ${gathered_name}$_MODULE -USE ${gathered_name}$_ACCESS_MODULE -USE ${gathered_name}$_FACTORY_MODULE -#:endif -#:endfor - -${fieldType.useParkind1 ()}$ - -IMPLICIT NONE - -PRIVATE - -#:for ft in fieldTypeList -#:if ft.rank >= 3 - -#:for what in ['DEVICE', 'HOST'] -#:for mode in ['RDONLY', 'RDWR'] - -INTERFACE PAIR_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ - MODULE PROCEDURE :: PAIR_${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ -END INTERFACE PAIR_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ - -PUBLIC :: PAIR_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ - -#:endfor -#:endfor - -INTERFACE PAIR_SCATTER_COLLAPSE2_DATA - MODULE PROCEDURE :: PAIR_${ft.name}$_SCATTER_COLLAPSE2_DATA -END INTERFACE PAIR_SCATTER_COLLAPSE2_DATA - -PUBLIC :: PAIR_SCATTER_COLLAPSE2_DATA - -TYPE ${ft.name}$_SHUFFLE_PAIR_COLLAPSE2 - INTEGER (KIND=JPIM) :: IMODE = -1 - INTEGER (KIND=JPIM) :: IWHAT = -1 - CLASS (${ft.name}$), POINTER :: YLSCAT => NULL () - CLASS (${gathered_name}$), POINTER :: YLGATH => NULL () - TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: NEXT => NULL () -END TYPE ${ft.name}$_SHUFFLE_PAIR_COLLAPSE2 - -PUBLIC :: ${ft.name}$_SHUFFLE_PAIR_COLLAPSE2 - -#:endif -#:endfor - -INTEGER (KIND=JPIM), PARAMETER :: NRDWR = 0, NRDONLY = 1, NHOST = 2, NDEVICE = 3 -INTEGER (KIND=JPIM), PARAMETER :: NLONDIM = 1, NLEVDIM = 2, NBLKDIM = 3 - -CONTAINS - -#:for ft in fieldTypeList -#:if ft.rank >= 3 - -#:set collapsed_rank = ft.rank - 1 -#:set collapsed_shape = ','.join([':'] * collapsed_rank) -#:set gathered_name = ft.name.replace(str(ft.rank), str(ft.rank - 1)) -#:set ind_list = list(map(lambda i: "J" + str(i), range(3, ft.rank))) -#:set ind_str = ', '.join(ind_list) -#:if len(ind_list) > 0 -#:set ind_str_comma = ind_str + ', ' -#:else -#:set ind_str_comma = '' -#:endif - -#:for what in ['DEVICE', 'HOST'] -#:for mode in ['RDONLY', 'RDWR'] - -SUBROUTINE PAIR_${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ (YDPAIR, LDNULL, KLON, KGPBLKS, YDFINDS, PTR, YLF, KBLKMIN, KBLKMAX) - -USE FIELD_3IM_MODULE -USE FIELD_3IM_ACCESS_MODULE -USE FIELD_3IM_FACTORY_MODULE - -TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: YDPAIR -LOGICAL, INTENT (IN) :: LDNULL -INTEGER (KIND=JPIM), INTENT (IN) :: KLON, KGPBLKS -CLASS (FIELD_3IM), POINTER :: YDFINDS -${ft.type}$, POINTER :: PTR(${collapsed_shape}$) -CLASS (${ft.name}$), POINTER, OPTIONAL :: YLF -INTEGER (KIND=JPIM), INTENT (IN) :: KBLKMIN -INTEGER (KIND=JPIM), INTENT (IN) :: KBLKMAX - -${ft.type}$, POINTER :: ZTRG(${collapsed_shape}$), ZTRS(${ft.shape}$) -${ft.type}$, POINTER :: ZSRC(${ft.shape}$) -TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: YLPAIR -CLASS (${gathered_name}$), POINTER :: YLGATH_DUMM -INTEGER (KIND=JPIM) :: ILBOUNDS (${collapsed_rank}$), IUBOUNDS (${collapsed_rank}$) -INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) - -IF (LDNULL) THEN - - ! Return dummy pointer - YLGATH_DUMM => NULL () - PTR => GET_${what}$_DATA_${mode}$ (YLGATH_DUMM) - -ELSE - - ZSRC => GET_${what}$_DATA_RDONLY (YLF) - - ALLOCATE (YLPAIR) - YLPAIR%IMODE = N${mode}$ - YLPAIR%IWHAT = N${what}$ - YLPAIR%NEXT => YDPAIR - YDPAIR => YLPAIR - YLPAIR%YLSCAT => YLF - - ILBOUNDS (1) = 1 - IUBOUNDS (1) = KLON - -#:for i in range(3, ft.rank) - ILBOUNDS (${i - 1}$) = LBOUND (ZSRC, ${i}$) - IUBOUNDS (${i - 1}$) = UBOUND (ZSRC, ${i}$) -#:endfor - - ILBOUNDS (${collapsed_rank}$) = 1 - IUBOUNDS (${collapsed_rank}$) = KGPBLKS - - CALL FIELD_NEW (YLPAIR%YLGATH, LBOUNDS=ILBOUNDS, UBOUNDS=IUBOUNDS, PERSISTENT=.TRUE.) - - INDS => GET_${what}$_DATA_RDONLY (YDFINDS) - ZTRS => GET_${what}$_DATA_RDONLY (YLPAIR%YLSCAT) - ZTRG => GET_${what}$_DATA_RDWR (YLPAIR%YLGATH) - - CALL PAIR_${ft.name}$_COLLAPSE2_${what}$_${mode}$ (INDS) - - ! Return pointer on packed array - PTR => GET_${what}$_DATA_${mode}$ (YLPAIR%YLGATH) - -ENDIF - - -CONTAINS - -SUBROUTINE PAIR_${ft.name}$_COLLAPSE2_${what}$_${mode}$ (KNDS) - -INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) -INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, JLEVS - -#:if len(ind_list) > 0 -INTEGER (KIND=JPIM) :: ${ind_str}$ -#:endif - -#:if what == 'DEVICE' -$:offload_macros.parallel_gang_loop(present=['ZTRG', 'ZTRS', 'KNDS']) -#:elif what == 'HOST' -!$OMP PARALLEL DO PRIVATE (${ind_str_comma}$JBLKG, JLONG, JBLKS, JLONS, JLEVS) -#:endif -DO JBLKG = 1, SIZE (KNDS, 3) -#:if what == 'DEVICE' -$:offload_macros.parallel_vector_loop(private=['JLONG', 'JBLKS', 'JLONS', 'JLEVS']) -#:endif - DO JLONG = 1, SIZE (KNDS, 2) - JLONS = KNDS (NLONDIM, JLONG, JBLKG) - JLEVS = KNDS (NLEVDIM, JLONG, JBLKG) - JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) - IF (JLONS > 0) THEN -#:for i in range(3, ft.rank) - DO J${i}$ = LBOUND (ZTRG, ${i - 1}$), UBOUND (ZTRG, ${i - 1}$) -#:endfor - ZTRG (JLONG, ${ind_str_comma}$JBLKG) = ZTRS (JLONS, JLEVS, ${ind_str_comma}$JBLKS) -#:for i in reversed(range(3, ft.rank)) - ENDDO -#:endfor - ENDIF - ENDDO -ENDDO - -END SUBROUTINE - -END SUBROUTINE PAIR_${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ - -#:endfor -#:endfor - -SUBROUTINE PAIR_${ft.name}$_SCATTER_COLLAPSE2_DATA (YDPAIR, YDFINDS) - -USE FIELD_3IM_MODULE -USE FIELD_3IM_ACCESS_MODULE -USE FIELD_3IM_FACTORY_MODULE - -TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: YDPAIR -CLASS (FIELD_3IM), POINTER :: YDFINDS - -TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: YLPAIR -${ft.type}$, POINTER :: PTRG(${collapsed_shape}$), PTRS(${ft.shape}$) -INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) - -DO WHILE (ASSOCIATED (YDPAIR)) - - YLPAIR => YDPAIR%NEXT - - ! Scatter back results - IF (YDPAIR%IMODE == NRDWR) THEN - IF (YDPAIR%IWHAT == NDEVICE) THEN - - INDS => GET_DEVICE_DATA_RDONLY (YDFINDS) - PTRG => GET_DEVICE_DATA_RDONLY (YDPAIR%YLGATH) - PTRS => GET_DEVICE_DATA_RDWR (YDPAIR%YLSCAT) - - CALL ${ft.name}$_SCATTER_COLLAPSE2_DEVICE_KERNEL (INDS) - - ELSEIF (YDPAIR%IWHAT == NHOST) THEN - - INDS => GET_HOST_DATA_RDONLY (YDFINDS) - PTRG => GET_HOST_DATA_RDONLY (YDPAIR%YLGATH) - PTRS => GET_HOST_DATA_RDWR (YDPAIR%YLSCAT) - - CALL ${ft.name}$_SCATTER_COLLAPSE2_HOST_KERNEL (INDS) - - ENDIF - ENDIF - - CALL FIELD_DELETE (YDPAIR%YLGATH) - DEALLOCATE (YDPAIR) - NULLIFY (YDPAIR) - - YDPAIR => YLPAIR -ENDDO - -CONTAINS - -#:for what in ['DEVICE', 'HOST'] -SUBROUTINE ${ft.name}$_SCATTER_COLLAPSE2_${what}$_KERNEL (KNDS) - -INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) -INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, JLEVS - -#:if len(ind_list) > 0 -INTEGER (KIND=JPIM) :: ${ind_str}$ -#:endif - -#:if what == 'DEVICE' -$:offload_macros.parallel_gang_loop(present=['PTRG', 'PTRS', 'KNDS']) -#:elif what == 'HOST' -!$OMP PARALLEL DO PRIVATE (${ind_str_comma}$JBLKG, JLONG, JBLKS, JLONS, JLEVS) -#:endif -DO JBLKG = 1, SIZE (KNDS, 3) -#:if what == 'DEVICE' -$:offload_macros.parallel_vector_loop(private=['JLONG', 'JBLKS', 'JLONS', 'JLEVS']) -#:endif - DO JLONG = 1, SIZE (KNDS, 2) - JLONS = KNDS (NLONDIM, JLONG, JBLKG) - JLEVS = KNDS (NLEVDIM, JLONG, JBLKG) - JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) - IF (JLONS > 0) THEN -#:for i in range(3, ft.rank) - DO J${i}$ = LBOUND (PTRG, ${i - 1}$), UBOUND (PTRG, ${i - 1}$) -#:endfor - PTRS (JLONS, JLEVS, ${ind_str_comma}$JBLKS) = PTRG (JLONG, ${ind_str_comma}$JBLKG) -#:for i in reversed(range(3, ft.rank)) - ENDDO -#:endfor - ENDIF - ENDDO -ENDDO - -END SUBROUTINE - -#:endfor -END SUBROUTINE PAIR_${ft.name}$_SCATTER_COLLAPSE2_DATA - -#:endif -#:endfor - -END MODULE FIELD_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE2_MODULE diff --git a/src/shuffle/field_RANKSUFF_shuffle_collapseCOLLAPSE_module.fypp b/src/shuffle/field_RANKSUFF_shuffle_collapseCOLLAPSE_module.fypp new file mode 100644 index 00000000..fe15a1ae --- /dev/null +++ b/src/shuffle/field_RANKSUFF_shuffle_collapseCOLLAPSE_module.fypp @@ -0,0 +1,394 @@ +#! (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_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE${COLLAPSE}$_MODULE + +#:set fieldTypeList = fieldType.getFieldTypeList (ranks=[RANK], kinds=['JP' + SUFF], hasView=True) + +USE FIELD_${RANK}$${SUFF}$_MODULE +USE FIELD_${RANK}$${SUFF}$_ACCESS_MODULE +USE FIELD_${RANK}$${SUFF}$_FACTORY_MODULE +USE FIELD_ABORT_MODULE + +#:if COLLAPSE == 2 +#:for ft in fieldTypeList +#:if ft.rank >= COLLAPSE + 1 +#:set gathered_name = ft.name.replace(str(ft.rank), str(ft.rank - 1)) +USE ${gathered_name}$_MODULE +USE ${gathered_name}$_ACCESS_MODULE +USE ${gathered_name}$_FACTORY_MODULE +#:endif +#:endfor +#:endif + +${fieldType.useParkind1 ()}$ + +IMPLICIT NONE + +PRIVATE + +#:for ft in fieldTypeList +#:if ft.rank >= COLLAPSE + 1 + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +INTERFACE PAIR_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ + MODULE PROCEDURE :: PAIR_${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ +END INTERFACE PAIR_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ + +PUBLIC :: PAIR_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ + +#:endfor +#:endfor + +INTERFACE PAIR_SCATTER_COLLAPSE${COLLAPSE}$_DATA + MODULE PROCEDURE :: PAIR_${ft.name}$_SCATTER_COLLAPSE${COLLAPSE}$_DATA +END INTERFACE PAIR_SCATTER_COLLAPSE${COLLAPSE}$_DATA + +PUBLIC :: PAIR_SCATTER_COLLAPSE${COLLAPSE}$_DATA + +TYPE ${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$ + INTEGER (KIND=JPIM) :: IMODE = -1 + INTEGER (KIND=JPIM) :: IWHAT = -1 + CLASS (${ft.name}$), POINTER :: YLSCAT => NULL () +#:if COLLAPSE == 1 + CLASS (${ft.name}$), POINTER :: YLGATH => NULL () +#:elif COLLAPSE == 2 + CLASS (${gathered_name}$), POINTER :: YLGATH => NULL () +#:endif + TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$), POINTER :: NEXT => NULL () +END TYPE ${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$ + +PUBLIC :: ${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$ + +#:endif +#:endfor + +INTEGER (KIND=JPIM), PARAMETER :: NRDWR = 0, NRDONLY = 1, NHOST = 2, NDEVICE = 3 +INTEGER (KIND=JPIM), PARAMETER :: NLONDIM = 1 +#:if COLLAPSE == 2 +INTEGER (KIND=JPIM), PARAMETER :: NLEVDIM = 2 +#:endif +INTEGER (KIND=JPIM), PARAMETER :: NBLKDIM = ${COLLAPSE + 1}$ + +CONTAINS + +#:for ft in fieldTypeList +#:if ft.rank >= COLLAPSE + 1 + +#:if COLLAPSE == 1 +#:set gathered_shape = ft.shape +#:set gathered_rank = ft.rank +#:elif COLLAPSE == 2 +#:set gathered_name = ft.name.replace(str(ft.rank), str(ft.rank - 1)) +#:set gathered_rank = ft.rank - 1 +#:set gathered_shape = ','.join([':'] * gathered_rank) +#:endif + +#:set src_ind_list = list(map(lambda i: "J" + str(i), range(2, ft.rank))) +#:set src_ind_str = ', '.join(src_ind_list) +#:if len(src_ind_list) > 0 +#:set src_ind_comma = src_ind_str + ', ' +#:else +#:set src_ind_comma = '' +#:endif + +#:if COLLAPSE == 1 +#:set tgt_ind_list = list(map(lambda i: "J" + str(i), range(2, ft.rank))) +#:elif COLLAPSE == 2 +#:set tgt_ind_list = list(map(lambda i: "J" + str(i), range(3, ft.rank))) +#:endif +#:set tgt_ind_str = ', '.join(tgt_ind_list) +#:if len(tgt_ind_list) > 0 +#:set tgt_ind_comma = tgt_ind_str + ', ' +#:else +#:set tgt_ind_comma = '' +#:endif + +#:for what in ['DEVICE', 'HOST'] +#:for mode in ['RDONLY', 'RDWR'] + +SUBROUTINE PAIR_${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ (YDPAIR, LDNULL, LDFULL, KLON, KGPBLKS, YDFINDS, PTR, YLF, KBLKMIN, KBLKMAX) + +USE FIELD_3IM_MODULE +USE FIELD_3IM_ACCESS_MODULE +USE FIELD_3IM_FACTORY_MODULE + +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$), POINTER :: YDPAIR +LOGICAL, INTENT (IN) :: LDNULL, LDFULL +INTEGER (KIND=JPIM), INTENT (IN) :: KLON, KGPBLKS +CLASS (FIELD_3IM), POINTER :: YDFINDS +${ft.type}$, POINTER :: PTR(${gathered_shape}$) +CLASS (${ft.name}$), POINTER, OPTIONAL :: YLF +INTEGER (KIND=JPIM), INTENT (IN) :: KBLKMIN +INTEGER (KIND=JPIM), INTENT (IN) :: KBLKMAX + +${ft.type}$, POINTER :: ZTRG(${gathered_shape}$), ZTRS(${ft.shape}$) +#:if COLLAPSE == 2 +${ft.type}$, POINTER :: ZSRC(${ft.shape}$) +#:endif +#:if COLLAPSE == 1 +${ft.type}$, POINTER :: PTR1(${ft.shape}$) +#:endif +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$), POINTER :: YLPAIR +#:if COLLAPSE == 1 +CLASS (${ft.name}$), POINTER :: YLGATH_DUMM +#:elif COLLAPSE == 2 +CLASS (${gathered_name}$), POINTER :: YLGATH_DUMM +#:endif +INTEGER (KIND=JPIM) :: ILBOUNDS (${gathered_rank}$), IUBOUNDS (${gathered_rank}$) +INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) + +IF (LDNULL) THEN + + ! Return dummy pointer + YLGATH_DUMM => NULL () + PTR => GET_${what}$_DATA_${mode}$ (YLGATH_DUMM) + +ELSEIF (LDFULL) THEN + +#:if COLLAPSE == 1 + ! Return pointer on packed array + PTR => GET_${what}$_DATA_${mode}$ (YLF) + + ! Set last lbound to 1 + + 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 +#:elif COLLAPSE == 2 + CALL FIELD_ABORT ('LDFULL SHOULD NEVER BE TRUE FOR COLLAPSE2') +#:endif + +ELSE + +#:if COLLAPSE == 1 + PTR => GET_${what}$_DATA_RDONLY (YLF) +#:elif COLLAPSE == 2 + ZSRC => GET_${what}$_DATA_RDONLY (YLF) +#:endif + + ALLOCATE (YLPAIR) + YLPAIR%IMODE = N${mode}$ + YLPAIR%IWHAT = N${what}$ + YLPAIR%NEXT => YDPAIR + YDPAIR => YLPAIR + YLPAIR%YLSCAT => YLF + +#:if COLLAPSE == 1 + ILBOUNDS = LBOUND (PTR) + IUBOUNDS = UBOUND (PTR) + + ILBOUNDS (1) = 1 + IUBOUNDS (1) = KLON + + ILBOUNDS (${ft.rank}$) = 1 + IUBOUNDS (${ft.rank}$) = KGPBLKS +#:elif COLLAPSE == 2 + ILBOUNDS (1) = 1 + IUBOUNDS (1) = KLON + +#:for i in range(3, ft.rank) + ILBOUNDS (${i - 1}$) = LBOUND (ZSRC, ${i}$) + IUBOUNDS (${i - 1}$) = UBOUND (ZSRC, ${i}$) +#:endfor + + ILBOUNDS (${gathered_rank}$) = 1 + IUBOUNDS (${gathered_rank}$) = KGPBLKS +#:endif + + CALL FIELD_NEW (YLPAIR%YLGATH, LBOUNDS=ILBOUNDS, UBOUNDS=IUBOUNDS, PERSISTENT=.TRUE.) + + INDS => GET_${what}$_DATA_RDONLY (YDFINDS) + ZTRS => GET_${what}$_DATA_RDONLY (YLPAIR%YLSCAT) + ZTRG => GET_${what}$_DATA_RDWR (YLPAIR%YLGATH) + + CALL PAIR_${ft.name}$_COLLAPSE${COLLAPSE}$_${what}$_${mode}$ (INDS) + + ! Return pointer on packed array + PTR => GET_${what}$_DATA_${mode}$ (YLPAIR%YLGATH) + +ENDIF + + +CONTAINS + +SUBROUTINE PAIR_${ft.name}$_COLLAPSE${COLLAPSE}$_${what}$_${mode}$ (KNDS) + +INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) +INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG +#:if COLLAPSE == 2 +INTEGER (KIND=JPIM) :: JLEVS +#:endif + +#:if len(tgt_ind_list) > 0 +INTEGER (KIND=JPIM) :: ${tgt_ind_str}$ +#:endif + +#:if what == 'DEVICE' +$:offload_macros.parallel_gang_loop(present=['ZTRG', 'ZTRS', 'KNDS']) +#:elif what == 'HOST' +!$OMP PARALLEL DO PRIVATE (${tgt_ind_comma}$JBLKG, JLONG, JBLKS, JLONS${', JLEVS' if COLLAPSE == 2 else ''}$) +#:endif +DO JBLKG = 1, SIZE (KNDS, 3) +#:if what == 'DEVICE' +#:if COLLAPSE == 1 +$:offload_macros.parallel_vector_loop(private=['JLONG', 'JBLKS', 'JLONS']) +#:elif COLLAPSE == 2 +$:offload_macros.parallel_vector_loop(private=['JLONG', 'JBLKS', 'JLONS', 'JLEVS']) +#:endif +#:endif + DO JLONG = 1, SIZE (KNDS, 2) + JLONS = KNDS (NLONDIM, JLONG, JBLKG) +#:if COLLAPSE == 2 + JLEVS = KNDS (NLEVDIM, JLONG, JBLKG) +#:endif + JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) + IF (JLONS > 0) THEN +#:if COLLAPSE == 1 +#:for i in range(2, ft.rank) + DO J${i}$ = LBOUND (ZTRG, ${i}$), UBOUND (ZTRG, ${i}$) +#:endfor + ZTRG (JLONG, ${src_ind_comma}$JBLKG) = ZTRS (JLONS, ${src_ind_comma}$JBLKS) +#:for i in reversed(range(2, ft.rank)) + ENDDO +#:endfor +#:elif COLLAPSE == 2 +#:for i in range(3, ft.rank) + DO J${i}$ = LBOUND (ZTRG, ${i - 1}$), UBOUND (ZTRG, ${i - 1}$) +#:endfor + ZTRG (JLONG, ${tgt_ind_comma}$JBLKG) = ZTRS (JLONS, JLEVS, ${tgt_ind_comma}$JBLKS) +#:for i in reversed(range(3, ft.rank)) + ENDDO +#:endfor +#:endif + ENDIF + ENDDO +ENDDO + +END SUBROUTINE + +END SUBROUTINE PAIR_${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ + +#:endfor +#:endfor + +SUBROUTINE PAIR_${ft.name}$_SCATTER_COLLAPSE${COLLAPSE}$_DATA (YDPAIR, YDFINDS) + +USE FIELD_3IM_MODULE +USE FIELD_3IM_ACCESS_MODULE +USE FIELD_3IM_FACTORY_MODULE + +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$), POINTER :: YDPAIR +CLASS (FIELD_3IM), POINTER :: YDFINDS + +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$), POINTER :: YLPAIR +${ft.type}$, POINTER :: PTRG(${gathered_shape}$), PTRS(${ft.shape}$) +INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) + +DO WHILE (ASSOCIATED (YDPAIR)) + + YLPAIR => YDPAIR%NEXT + + ! Scatter back results + IF (YDPAIR%IMODE == NRDWR) THEN + IF (YDPAIR%IWHAT == NDEVICE) THEN + + INDS => GET_DEVICE_DATA_RDONLY (YDFINDS) + PTRG => GET_DEVICE_DATA_RDONLY (YDPAIR%YLGATH) + PTRS => GET_DEVICE_DATA_RDWR (YDPAIR%YLSCAT) + + CALL ${ft.name}$_SCATTER_COLLAPSE${COLLAPSE}$_DEVICE_KERNEL (INDS) + + ELSEIF (YDPAIR%IWHAT == NHOST) THEN + + INDS => GET_HOST_DATA_RDONLY (YDFINDS) + PTRG => GET_HOST_DATA_RDONLY (YDPAIR%YLGATH) + PTRS => GET_HOST_DATA_RDWR (YDPAIR%YLSCAT) + + CALL ${ft.name}$_SCATTER_COLLAPSE${COLLAPSE}$_HOST_KERNEL (INDS) + + ENDIF + ENDIF + + CALL FIELD_DELETE (YDPAIR%YLGATH) + DEALLOCATE (YDPAIR) + NULLIFY (YDPAIR) + + YDPAIR => YLPAIR +ENDDO + +CONTAINS + +#:for what in ['DEVICE', 'HOST'] +SUBROUTINE ${ft.name}$_SCATTER_COLLAPSE${COLLAPSE}$_${what}$_KERNEL (KNDS) + +INTEGER (KIND=JPIM), INTENT (IN) :: KNDS (:,:,:) +INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG +#:if COLLAPSE == 2 +INTEGER (KIND=JPIM) :: JLEVS +#:endif + +#:if len(tgt_ind_list) > 0 +INTEGER (KIND=JPIM) :: ${tgt_ind_str}$ +#:endif + +#:if what == 'DEVICE' +$:offload_macros.parallel_gang_loop(present=['PTRG', 'PTRS', 'KNDS']) +#:elif what == 'HOST' +!$OMP PARALLEL DO PRIVATE (${tgt_ind_comma}$JBLKG, JLONG, JBLKS, JLONS${', JLEVS' if COLLAPSE == 2 else ''}$) +#:endif +DO JBLKG = 1, SIZE (KNDS, 3) +#:if what == 'DEVICE' +#:if COLLAPSE == 1 +$:offload_macros.parallel_vector_loop(private=['JLONG', 'JBLKS', 'JLONS']) +#:elif COLLAPSE == 2 +$:offload_macros.parallel_vector_loop(private=['JLONG', 'JBLKS', 'JLONS', 'JLEVS']) +#:endif +#:endif + DO JLONG = 1, SIZE (KNDS, 2) + JLONS = KNDS (NLONDIM, JLONG, JBLKG) +#:if COLLAPSE == 2 + JLEVS = KNDS (NLEVDIM, JLONG, JBLKG) +#:endif + JBLKS = KNDS (NBLKDIM, JLONG, JBLKG) + IF (JLONS > 0) THEN +#:if COLLAPSE == 1 +#:for i in range(2, ft.rank) + DO J${i}$ = LBOUND (PTRG, ${i}$), UBOUND (PTRG, ${i}$) +#:endfor + PTRS (JLONS, ${src_ind_comma}$JBLKS) = PTRG (JLONG, ${src_ind_comma}$JBLKG) +#:for i in reversed(range(2, ft.rank)) + ENDDO +#:endfor +#:elif COLLAPSE == 2 +#:for i in range(3, ft.rank) + DO J${i}$ = LBOUND (PTRG, ${i - 1}$), UBOUND (PTRG, ${i - 1}$) +#:endfor + PTRS (JLONS, JLEVS, ${tgt_ind_comma}$JBLKS) = PTRG (JLONG, ${tgt_ind_comma}$JBLKG) +#:for i in reversed(range(3, ft.rank)) + ENDDO +#:endfor +#:endif + ENDIF + ENDDO +ENDDO + +END SUBROUTINE + +#:endfor +END SUBROUTINE PAIR_${ft.name}$_SCATTER_COLLAPSE${COLLAPSE}$_DATA + +#:endif +#:endfor + +END MODULE FIELD_${RANK}$${SUFF}$_SHUFFLE_COLLAPSE${COLLAPSE}$_MODULE diff --git a/src/shuffle/field_gathscat_collapse2_module.fypp b/src/shuffle/field_gathscat_collapseCOLLAPSE_module.fypp similarity index 67% rename from src/shuffle/field_gathscat_collapse2_module.fypp rename to src/shuffle/field_gathscat_collapseCOLLAPSE_module.fypp index e817ba25..6069bfb5 100644 --- a/src/shuffle/field_gathscat_collapse2_module.fypp +++ b/src/shuffle/field_gathscat_collapseCOLLAPSE_module.fypp @@ -7,17 +7,19 @@ #! granted to it by virtue of its status as an intergovernmental organisation #! nor does it submit to any jurisdiction. -MODULE FIELD_GATHSCAT_COLLAPSE2_MODULE +MODULE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$_MODULE #:set fieldTypeList = fieldType.getFieldTypeList (hasView=True) USE FIELD_ACCESS_MODULE USE FIELD_FACTORY_MODULE -USE FIELD_GATHSCAT_COLLAPSE2_TYPE_MODULE +USE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$_TYPE_MODULE ${fieldType.useParkind1 ()}$ #:for ft in fieldTypeList -USE ${ft.name}$_GATHER_COLLAPSE2_MODULE +#:if ft.rank >= COLLAPSE + 1 +USE ${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_MODULE +#:endif #:endfor @@ -25,15 +27,15 @@ IMPLICIT NONE PRIVATE -PUBLIC :: FIELD_GATHSCAT_COLLAPSE2 +PUBLIC :: FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ #:for what in ['DEVICE', 'HOST'] #:for mode in ['RDONLY', 'RDWR'] INTERFACE GATHER_${what}$_DATA_${mode}$ #:for ft in fieldTypeList -#:if ft.rank >= 3 - MODULE PROCEDURE ${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ +#:if ft.rank >= COLLAPSE + 1 + MODULE PROCEDURE ${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ #:endif #:endfor END INTERFACE GATHER_${what}$_DATA_${mode}$ @@ -42,8 +44,8 @@ PUBLIC :: GATHER_${what}$_DATA_${mode}$ INTERFACE SGATHER_${what}$_DATA_${mode}$ #:for ft in fieldTypeList -#:if ft.rank >= 3 - MODULE PROCEDURE S${ft.name}$_GATHER_COLLAPSE2_${what}$_DATA_${mode}$ +#:if ft.rank >= COLLAPSE + 1 + MODULE PROCEDURE S${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ #:endif #:endfor END INTERFACE SGATHER_${what}$_DATA_${mode}$ @@ -54,4 +56,4 @@ PUBLIC :: SGATHER_${what}$_DATA_${mode}$ #:endfor -END MODULE FIELD_GATHSCAT_COLLAPSE2_MODULE +END MODULE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$_MODULE diff --git a/src/shuffle/field_gathscat_collapse2_type_module.fypp b/src/shuffle/field_gathscat_collapseCOLLAPSE_type_module.fypp similarity index 56% rename from src/shuffle/field_gathscat_collapse2_type_module.fypp rename to src/shuffle/field_gathscat_collapseCOLLAPSE_type_module.fypp index 743d1385..27b82e9b 100644 --- a/src/shuffle/field_gathscat_collapse2_type_module.fypp +++ b/src/shuffle/field_gathscat_collapseCOLLAPSE_type_module.fypp @@ -7,19 +7,23 @@ #! granted to it by virtue of its status as an intergovernmental organisation #! nor does it submit to any jurisdiction. -MODULE FIELD_GATHSCAT_COLLAPSE2_TYPE_MODULE +MODULE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$_TYPE_MODULE #:set fieldTypeList = fieldType.getFieldTypeList (hasView=True) +#:if COLLAPSE == 1 +USE FIELD_2LM_MODULE, ONLY : FIELD_2LM +#:elif COLLAPSE == 2 USE FIELD_3LM_MODULE, ONLY : FIELD_3LM +#:endif USE FIELD_ACCESS_MODULE USE FIELD_FACTORY_MODULE USE FIELD_SHUFFLE_TYPE_MODULE ${fieldType.useParkind1 ()}$ #:for ft in fieldTypeList -#:if ft.rank >= 3 -USE ${ft.name}$_SHUFFLE_COLLAPSE2_MODULE +#:if ft.rank >= COLLAPSE + 1 +USE ${ft.name}$_SHUFFLE_COLLAPSE${COLLAPSE}$_MODULE #:endif #:endfor @@ -27,59 +31,78 @@ IMPLICIT NONE PRIVATE -TYPE, EXTENDS (FIELD_SHUFFLE) :: FIELD_GATHSCAT_COLLAPSE2 +TYPE, EXTENDS (FIELD_SHUFFLE) :: FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ #:for ft in fieldTypeList -#:if ft.rank >= 3 - TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: ${ft.name}$_C2LIST => NULL () +#:if ft.rank >= COLLAPSE + 1 + TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$), POINTER :: ${ft.name}$_C${COLLAPSE}$LIST => NULL () #:endif #:endfor CONTAINS - GENERIC :: INIT => INIT_FIELD_GATHSCAT_COLLAPSE2 - PROCEDURE :: INIT_FIELD_GATHSCAT_COLLAPSE2 - PROCEDURE :: SCATTER => SCATTER_FIELD_GATHSCAT_COLLAPSE2 -END TYPE FIELD_GATHSCAT_COLLAPSE2 + GENERIC :: INIT => INIT_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ + PROCEDURE :: INIT_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ + PROCEDURE :: SCATTER => SCATTER_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ +END TYPE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ -PUBLIC :: FIELD_GATHSCAT_COLLAPSE2 +PUBLIC :: FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ -INTEGER (KIND=JPIM), PARAMETER :: NLONDIM = 1, NLEVDIM = 2, NBLKDIM = 3 +INTEGER (KIND=JPIM), PARAMETER :: NLONDIM = 1 +#:if COLLAPSE == 2 +INTEGER (KIND=JPIM), PARAMETER :: NLEVDIM = 2 +#:endif +INTEGER (KIND=JPIM), PARAMETER :: NBLKDIM = ${COLLAPSE + 1}$ CONTAINS -SUBROUTINE INIT_FIELD_GATHSCAT_COLLAPSE2 (SELF, YDFCOND, KGPTOT, KLON_G, KBLKMIN, KBLKMAX) +SUBROUTINE INIT_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ (SELF, YDFCOND, KGPTOT, KLON_S, KLON_G, KBLKMIN, KBLKMAX) USE FIELD_ABORT_MODULE -CLASS (FIELD_GATHSCAT_COLLAPSE2) :: SELF +CLASS (FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$) :: SELF +#:if COLLAPSE == 1 +CLASS (FIELD_2LM), POINTER :: YDFCOND +#:elif COLLAPSE == 2 CLASS (FIELD_3LM), POINTER :: YDFCOND +#:endif INTEGER (KIND=JPIM), INTENT (IN) :: KGPTOT -INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: KLON_G +INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: KLON_S, KLON_G INTEGER (KIND=JPIM), INTENT (IN), OPTIONAL :: KBLKMIN, KBLKMAX +#:if COLLAPSE == 1 +LOGICAL, POINTER :: LLF (:,:) +#:elif COLLAPSE == 2 LOGICAL, POINTER :: LLF (:,:,:) +#:endif INTEGER (KIND=JPIM), POINTER :: INDS (:,:,:) -INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, I1S, I2S, JLEV +INTEGER (KIND=JPIM) :: JLONS, JBLKS, JLONG, JBLKG, I1S, I2S +#:if COLLAPSE == 2 +INTEGER (KIND=JPIM) :: JLEV +#:endif LLF => GET_HOST_DATA_RDONLY (YDFCOND) -SELF%KBLKMIN = LBOUND (LLF, 3) +SELF%KBLKMIN = LBOUND (LLF, ${COLLAPSE + 1}$) IF (PRESENT (KBLKMIN)) SELF%KBLKMIN = KBLKMIN -SELF%KBLKMAX = UBOUND (LLF, 3) +SELF%KBLKMAX = UBOUND (LLF, ${COLLAPSE + 1}$) IF (PRESENT (KBLKMAX)) SELF%KBLKMAX = KBLKMAX SELF%KLON_S = SIZE (LLF, 1) SELF%KGPBLKS_S = SELF%KBLKMAX - SELF%KBLKMIN + 1 SELF%KGPTOT_S = KGPTOT -! Reduction: count active (JLON, JLEV) pairs +! Reduction SELF%KGPTOT_G = 0 DO JBLKS = SELF%KBLKMIN, SELF%KBLKMAX I1S = 1 I2S = MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - SELF%KBLKMIN) * SELF%KLON_S) +#:if COLLAPSE == 1 + SELF%KGPTOT_G = SELF%KGPTOT_G + COUNT (LLF (I1S:I2S,JBLKS)) +#:elif COLLAPSE == 2 DO JLEV = LBOUND (LLF, 2), UBOUND (LLF, 2) SELF%KGPTOT_G = SELF%KGPTOT_G + COUNT (LLF (I1S:I2S, JLEV, JBLKS)) ENDDO +#:endif ENDDO IF (PRESENT (KLON_G)) THEN @@ -94,16 +117,22 @@ SELF%KGPTOT = SELF%KGPTOT_G SELF%KLON = SELF%KLON_G SELF%KGPBLKS = SELF%KGPBLKS_G +#:if COLLAPSE == 1 +SELF%LFULL = SELF%KGPTOT_G == SELF%KGPTOT_S +#:elif COLLAPSE == 2 ! For COLLAPSE2, we cannot avoid gather even when all points are active ! because the gathered array has a different rank (collapsed). SELF%LFULL = .FALSE. +#:endif SELF%LNULL = SELF%KGPTOT_G == 0 IF (SELF%LNULL) THEN ! Do nothing +ELSEIF (SELF%LFULL) THEN + ! Do nothing ELSE - CALL FIELD_NEW (SELF%YLFINDS, UBOUNDS=[3, SELF%KLON_G, SELF%KGPBLKS_G], PERSISTENT=.TRUE.) + CALL FIELD_NEW (SELF%YLFINDS, UBOUNDS=[${COLLAPSE + 1}$, SELF%KLON_G, SELF%KGPBLKS_G], PERSISTENT=.TRUE.) INDS => GET_HOST_DATA_RDWR (SELF%YLFINDS) ! Create indices (serial code) @@ -111,14 +140,22 @@ ELSE JBLKG = 1 JLONG = 1 DO JBLKS = SELF%KBLKMIN, SELF%KBLKMAX +#:if COLLAPSE == 2 DO JLEV = LBOUND (LLF, 2), UBOUND (LLF, 2) +#:endif DO JLONS = 1, MIN (SELF%KLON_S, SELF%KGPTOT_S - (JBLKS - SELF%KBLKMIN) * SELF%KLON_S) +#:if COLLAPSE == 1 + IF (LLF (JLONS, JBLKS)) THEN +#:elif COLLAPSE == 2 IF (LLF (JLONS, JLEV, JBLKS)) THEN +#:endif IF ((JLONG > SIZE (INDS, 2)) .OR. (JBLKG > SIZE (INDS, 3))) THEN - CALL FIELD_ABORT ('INIT_FIELD_GATHSCAT_COLLAPSE2: OUT OF BOUNDS') + CALL FIELD_ABORT ('INIT_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$: OUT OF BOUNDS') ENDIF INDS (NLONDIM, JLONG, JBLKG) = JLONS +#:if COLLAPSE == 2 INDS (NLEVDIM, JLONG, JBLKG) = JLEV +#:endif INDS (NBLKDIM, JLONG, JBLKG) = JBLKS JLONG = JLONG + 1 IF (JLONG > SELF%KLON_G) THEN @@ -127,13 +164,17 @@ ELSE ENDIF ENDIF ENDDO +#:if COLLAPSE == 2 ENDDO +#:endif ENDDO IF (JBLKG <= SIZE (INDS, 3)) THEN DO WHILE (JLONG <= SELF%KLON_G) INDS (NLONDIM, JLONG, JBLKG) = -9999999 +#:if COLLAPSE == 2 INDS (NLEVDIM, JLONG, JBLKG) = -9999999 +#:endif INDS (NBLKDIM, JLONG, JBLKG) = -9999999 JLONG = JLONG + 1 ENDDO @@ -143,21 +184,23 @@ ENDIF END SUBROUTINE -SUBROUTINE SCATTER_FIELD_GATHSCAT_COLLAPSE2 (SELF) -CLASS (FIELD_GATHSCAT_COLLAPSE2) :: SELF +SUBROUTINE SCATTER_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ (SELF) +CLASS (FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$) :: SELF #:for ft in fieldTypeList -#:if ft.rank >= 3 -TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE2), POINTER :: ${ft.name}$_C2LIST +#:if ft.rank >= COLLAPSE + 1 +TYPE (${ft.name}$_SHUFFLE_PAIR_COLLAPSE${COLLAPSE}$), POINTER :: ${ft.name}$_C${COLLAPSE}$LIST #:endif #:endfor IF (SELF%LNULL) THEN ! Do nothing +ELSEIF (SELF%LFULL) THEN + ! Do nothing ELSE #:for ft in fieldTypeList -#:if ft.rank >= 3 - CALL PAIR_SCATTER_COLLAPSE2_DATA (SELF%${ft.name}$_C2LIST, SELF%YLFINDS) +#:if ft.rank >= COLLAPSE + 1 + CALL PAIR_SCATTER_COLLAPSE${COLLAPSE}$_DATA (SELF%${ft.name}$_C${COLLAPSE}$LIST, SELF%YLFINDS) #:endif #:endfor @@ -179,4 +222,4 @@ SELF%KGPBLKS = -1 END SUBROUTINE -END MODULE FIELD_GATHSCAT_COLLAPSE2_TYPE_MODULE +END MODULE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$_TYPE_MODULE diff --git a/tests/gather_scatter_collapse1.F90 b/tests/gather_scatter_collapse1.F90 new file mode 100644 index 00000000..5b9d0076 --- /dev/null +++ b/tests/gather_scatter_collapse1.F90 @@ -0,0 +1,106 @@ +PROGRAM GATHER_SCATTER_COLLAPSE1 + +USE FIELD_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_ACCESS_MODULE +USE FIELD_GATHSCAT_COLLAPSE1_MODULE +USE PARKIND1 +USE FIELD_ABORT_MODULE + +IMPLICIT NONE + +INTEGER (KIND=JPIM), PARAMETER :: NPROMA = 10, NGPBLKS = 4, NFLEVG = 10, NGPTOT = NPROMA * NGPBLKS - 4 +INTEGER (KIND=JPIM), PARAMETER :: NMISS = -99999, NNEW = 22222 + +TYPE (FIELD_GATHSCAT_COLLAPSE1) :: YL_FGS + +LOGICAL :: LLTRIG (NPROMA, NGPBLKS) +CLASS (FIELD_2LM), POINTER :: YLTRIG => NULL () + +INTEGER (KIND=JPIM), ALLOCATABLE :: ID (:,:,:) +CLASS (FIELD_3IM), POINTER :: YLFD => NULL() + +INTEGER (KIND=JPIM),POINTER :: ID_FILTERED (:,:,:) => NULL () + +INTEGER (KIND=JPIM) :: JLON, JBLK, JLEV, IIDIA, IFDIA + +INTEGER (KIND=JPIM) :: FUNC + +FUNC (JLON, JLEV, JBLK) = (JBLK-1) * NPROMA + (JLON-1) + NGPTOT * (JLEV-1) + + +LLTRIG=.FALSE. + +DO JBLK = 1, NGPBLKS + IIDIA = 1 + IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) + DO JLON = IIDIA, IFDIA + LLTRIG (JLON, JBLK) = MOD (JLON, 2) == 0 + ENDDO +ENDDO + +CALL FIELD_NEW (YLTRIG, DATA=LLTRIG) + +ALLOCATE(ID (NPROMA, NFLEVG, NGPBLKS)) + +DO JBLK = 1, NGPBLKS + IIDIA = 1 + IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) + DO JLEV = 1, NFLEVG + DO JLON = IIDIA, IFDIA + ID (JLON, JLEV, JBLK) = FUNC (JLON, JLEV, JBLK) + ENDDO + DO JLON = IFDIA+1, NPROMA + ID (JLON, JLEV, JBLK) = NMISS + ENDDO + ENDDO +ENDDO + +CALL FIELD_NEW (YLFD, DATA=ID) + +CALL YL_FGS%INIT (YLTRIG, NGPTOT) +ID_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFD) + +DO JBLK = 1, YL_FGS%KGPBLKS + IIDIA = 1 + IFDIA = MERGE (YL_FGS%KLON, YL_FGS%KGPTOT - (JBLK - 1) * YL_FGS%KLON, JBLK < YL_FGS%KGPBLKS) + DO JLEV = 1, NFLEVG + DO JLON = IIDIA, IFDIA + ID_FILTERED (JLON, JLEV, JBLK) = NNEW + ENDDO + DO JLON = IFDIA+1, YL_FGS%KLON + ID_FILTERED (JLON, JLEV, JBLK) = NMISS + ENDDO + ENDDO +ENDDO + +CALL YL_FGS%SCATTER () + +DO JBLK = 1, NGPBLKS + IIDIA = 1 + IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) + + DO JLEV = 1, NFLEVG + + DO JLON = IIDIA, IFDIA + IF (LLTRIG (JLON, JBLK)) THEN + IF (ID (JLON, JLEV, JBLK) /= NNEW) & + & CALL FIELD_ABORT ("ERROR") + ELSE + IF (ID (JLON, JLEV, JBLK) /= FUNC (JLON, JLEV, JBLK)) & + & CALL FIELD_ABORT ("ERROR") + ENDIF + ENDDO + + DO JLON = IFDIA+1, NPROMA + IF (ID (JLON, JLEV, JBLK) /= NMISS) & + & CALL FIELD_ABORT ("ERROR") + ENDDO + + ENDDO + +ENDDO + +CALL FIELD_DELETE (YLTRIG) + +END PROGRAM diff --git a/tests/gather_scatter_collapse1_lastdim.F90 b/tests/gather_scatter_collapse1_lastdim.F90 new file mode 100644 index 00000000..b2339ad0 --- /dev/null +++ b/tests/gather_scatter_collapse1_lastdim.F90 @@ -0,0 +1,148 @@ +! (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_COLLAPSE1_LASTDIM +!TEST THAT FIELD_GATHSCAT_COLLAPSE1 ONLY MODIFY VALUES THAT HAVE BEEN FILTERED +USE FIELD_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_ACCESS_MODULE +USE FIELD_GATHSCAT_COLLAPSE1_MODULE +USE PARKIND1 +USE FIELD_ABORT_MODULE +IMPLICIT NONE + +TYPE (FIELD_GATHSCAT_COLLAPSE1):: 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, 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, '("===========> PASS = ",A4,", JBOFF ",I0," <===========")') CLTYPE (JPASS), JBOFF + + !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 + + 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, JBLKL:JBLKU)) + + D = 1 + + CALL FIELD_NEW (FD, DATA=D, LBOUNDS=[1,0,JBLKL]) + + 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 () + + 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 (ANY (D (:,:,JBLK) /= 1)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + ENDIF + END SELECT + ENDDO + + DEALLOCATE (D) + + CALL FIELD_DELETE (FTRIG) + +ENDDO +ENDDO + +END PROGRAM diff --git a/tests/gather_scatter_collapse2.F90 b/tests/gather_scatter_collapse2.F90 index f83268a1..0d7ab4da 100644 --- a/tests/gather_scatter_collapse2.F90 +++ b/tests/gather_scatter_collapse2.F90 @@ -20,15 +20,19 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 INTEGER (KIND=JPIM), ALLOCATABLE :: ID (:,:,:,:) CLASS (FIELD_4IM), POINTER :: YLFD => NULL() -INTEGER (KIND=JPIM),POINTER :: ID_FILTERED (:,:,:) => NULL () +INTEGER (KIND=JPIM),POINTER :: ID_FILTERED (:,:,:) => NULL (), ID1 (:,:,:,:) => NULL () -INTEGER (KIND=JPIM) :: JLON, JBLK, JLEV, JFLD, IIDIA, IFDIA +INTEGER (KIND=JPIM) :: JLON, JBLK, JLEV, JFLD, IIDIA, IFDIA, JPASS INTEGER (KIND=JPIM) :: FUNC FUNC (JLON, JLEV, JFLD, JBLK) = (JBLK-1) * NPROMA + (JLON-1) + NGPTOT * (JLEV-1 + NFLEVG * (JFLD-1)) +DO JPASS = 1, 2 ! 1=CPU, 2=GPU + +! fill condition array + LLTRIG = .FALSE. DO JBLK = 1, NGPBLKS @@ -45,6 +49,8 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 ALLOCATE(ID (NPROMA, NFLEVG, NFLD, NGPBLKS)) +! fill data array + DO JBLK = 1, NGPBLKS IIDIA = 1 IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) @@ -63,7 +69,22 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 CALL FIELD_NEW (YLFD, DATA=ID) CALL YL_FGS%INIT (YLTRIG, NGPTOT) -ID_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFD) + +! get pointer on filtered data + +IF (JPASS == 1) THEN + ID_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFD) +ELSE + ID_FILTERED => GATHER_DEVICE_DATA_RDWR (YL_FGS, YLFD) +ENDIF + +! update filtered data + +#ifdef OMPGPU +!$OMP TARGET +#else +!$ACC SERIAL PRESENT (ID_FILTERED) COPYIN (YL_FGS) IF (JPASS == 2) +#endif DO JBLK = 1, YL_FGS%KGPBLKS IIDIA = 1 @@ -78,8 +99,20 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 ENDDO ENDDO +#ifdef OMPGPU +!$OMP END TARGET +#else +!$ACC END SERIAL +#endif + +! scatter back + CALL YL_FGS%SCATTER () +! get data on host for verification + +ID1 => GET_HOST_DATA_RDONLY (YLFD) + DO JBLK = 1, NGPBLKS IIDIA = 1 IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) @@ -89,16 +122,16 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 DO JLON = IIDIA, IFDIA IF (LLTRIG (JLON, JLEV, JBLK)) THEN - IF (ID (JLON, JLEV, JFLD, JBLK) /= NNEW) & + IF (ID1 (JLON, JLEV, JFLD, JBLK) /= NNEW) & & CALL FIELD_ABORT ("ERROR") ELSE - IF (ID (JLON, JLEV, JFLD, JBLK) /= FUNC (JLON, JLEV, JFLD, JBLK)) & + IF (ID1 (JLON, JLEV, JFLD, JBLK) /= FUNC (JLON, JLEV, JFLD, JBLK)) & & CALL FIELD_ABORT ("ERROR") ENDIF ENDDO DO JLON = IFDIA+1, NPROMA - IF (ID (JLON, JLEV, JFLD, JBLK) /= NMISS) & + IF (ID1 (JLON, JLEV, JFLD, JBLK) /= NMISS) & & CALL FIELD_ABORT ("ERROR") ENDDO @@ -107,6 +140,16 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 ENDDO +! clear data + +NULLIFY (ID1) + +CALL FIELD_DELETE (YLFD) + +DEALLOCATE (ID) + CALL FIELD_DELETE (YLTRIG) +ENDDO + END PROGRAM diff --git a/tests/gather_scatter_collapse2_lastdim.F90 b/tests/gather_scatter_collapse2_lastdim.F90 new file mode 100644 index 00000000..d64dbbd3 --- /dev/null +++ b/tests/gather_scatter_collapse2_lastdim.F90 @@ -0,0 +1,147 @@ +! (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_COLLAPSE2_LASTDIM +!TEST THAT FIELD_GATHSCAT_COLLAPSE2 ONLY MODIFY VALUES THAT HAVE BEEN FILTERED +USE FIELD_MODULE +USE FIELD_FACTORY_MODULE +USE FIELD_ACCESS_MODULE +USE FIELD_GATHSCAT_COLLAPSE2_MODULE +USE PARKIND1 +USE FIELD_ABORT_MODULE +IMPLICIT NONE + +TYPE (FIELD_GATHSCAT_COLLAPSE2):: FGS +CLASS (FIELD_3LM), POINTER :: FTRIG => NULL() + +CHARACTER*4, PARAMETER :: CLTYPE (3) = ['PART', 'NULL', 'FULL'] + +INTEGER, PARAMETER :: NPROMA = 10, NFLEVG = 5, NFLD = 2, JBLKA = 2, JBLKB = 5, NGPBLKS = JBLKB - JBLKA + 1 + +LOGICAL :: TRIG (NPROMA, 0:NFLEVG, JBLKA:JBLKB) + +INTEGER :: I, J, JLEV, JPASS, JBOFF +INTEGER :: JBLKL, JBLKU, JBLK + +INTEGER (KIND=JPIM), ALLOCATABLE :: D (:,:,:,:) +CLASS (FIELD_4IM), POINTER :: FD => NULL() + +INTEGER (KIND=JPIM), POINTER :: FILTERED_D(:,:,:) => NULL() + +DO JBOFF = 1, 2 +DO JPASS = 1, 3 + + WRITE (0, '("===========> PASS = ",A4,", JBOFF ",I0," <===========")') CLTYPE (JPASS), JBOFF + + !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 EVEN COLUMNS + TRIG (I, :, :)=.TRUE. + ENDIF + ENDDO + CASE (2) + TRIG = .FALSE. + 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,0,JBLKA]) + + !CREATE THE FIELD TO BE FILTERED BY GATHSCAT + ALLOCATE (D (NPROMA, 0:NFLEVG, NFLD, JBLKL:JBLKU)) + + D = 1 + + CALL FIELD_NEW (FD, DATA=D, LBOUNDS=[1,0,1,JBLKL]) + + 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, 2) /= 1) CALL FIELD_ABORT ('LBOUND MISMATCH') + IF (UBOUND (FILTERED_D, 2) /= NFLD) CALL FIELD_ABORT ('UBOUND MISMATCH') + ENDIF + + !ACTUALLY UPDATE THE D ARRAY WITH THE MODIFIED DATA + + CALL FGS%SCATTER () + + 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 (ANY (D (:,:,:,JBLK) /= 1)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + ENDIF + END SELECT + ENDDO + + DEALLOCATE (D) + + CALL FIELD_DELETE (FTRIG) + +ENDDO +ENDDO + +END PROGRAM From 75e5d907bb8547957234defa85267040ca7dd4bf Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Mon, 29 Jun 2026 19:33:55 +0000 Subject: [PATCH 6/8] Shared libs with NVHPC --- cmake/field_api_get_lib_type.cmake | 1 - 1 file changed, 1 deletion(-) diff --git a/cmake/field_api_get_lib_type.cmake b/cmake/field_api_get_lib_type.cmake index 06eb9b97..90734408 100644 --- a/cmake/field_api_get_lib_type.cmake +++ b/cmake/field_api_get_lib_type.cmake @@ -51,5 +51,4 @@ macro( field_api_get_lib_type ) endif() endif() - set( field_api_lib_type STATIC ) endmacro() From 6a50bfeb05952c5d8622ed8a48d9103b749bd76f Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Wed, 8 Jul 2026 08:15:41 +0000 Subject: [PATCH 7/8] Test gather/scatter collapse2 feature with arrays whose second dimension is larger than NFLEVG. This can happen when processing arrays with extra levels such as : REAL (KIND=JPRB) :: ZFLD (NPROMA, 0:NFLEVG) --- tests/gather_scatter_collapse2.F90 | 129 +++++++++++++++++++++++++---- 1 file changed, 113 insertions(+), 16 deletions(-) diff --git a/tests/gather_scatter_collapse2.F90 b/tests/gather_scatter_collapse2.F90 index 0d7ab4da..b94053f9 100644 --- a/tests/gather_scatter_collapse2.F90 +++ b/tests/gather_scatter_collapse2.F90 @@ -11,6 +11,8 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 INTEGER (KIND=JPIM), PARAMETER :: NPROMA = 10, NGPBLKS = 4, NFLEVG = 10, NFLD = 5, NGPTOT = NPROMA * NGPBLKS - 4 INTEGER (KIND=JPIM), PARAMETER :: NMISS = -99999, NNEW = 22222 +INTEGER (KIND=JPIM), PARAMETER :: NLEV0 = 0, NLEV1 = NFLEVG+1 + TYPE (FIELD_GATHSCAT_COLLAPSE2) :: YL_FGS @@ -18,11 +20,14 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 CLASS (FIELD_3LM), POINTER :: YLTRIG => NULL () INTEGER (KIND=JPIM), ALLOCATABLE :: ID (:,:,:,:) -CLASS (FIELD_4IM), POINTER :: YLFD => NULL() +CLASS (FIELD_4IM), POINTER :: YLFID => NULL() +INTEGER (KIND=JPIM),POINTER :: IDPTR_FILTERED (:,:,:) => NULL (), IDPTR (:,:,:,:) => NULL () -INTEGER (KIND=JPIM),POINTER :: ID_FILTERED (:,:,:) => NULL (), ID1 (:,:,:,:) => NULL () +INTEGER (KIND=JPIM), ALLOCATABLE :: ID1 (:,:,:,:) +CLASS (FIELD_4IM), POINTER :: YLFID1 => NULL() +INTEGER (KIND=JPIM),POINTER :: ID1PTR_FILTERED (:,:,:) => NULL (), ID1PTR (:,:,:,:) => NULL () -INTEGER (KIND=JPIM) :: JLON, JBLK, JLEV, JFLD, IIDIA, IFDIA, JPASS +INTEGER (KIND=JPIM) :: JLON, JBLK, JLEV, JFLD, IIDIA, IFDIA, JPASS, IVALID, ISIZE INTEGER (KIND=JPIM) :: FUNC @@ -66,16 +71,65 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 ENDDO ENDDO -CALL FIELD_NEW (YLFD, DATA=ID) +! Field with extra levels (top & bottom) + +CALL FIELD_NEW (YLFID, DATA=ID) + +ALLOCATE(ID1 (NPROMA, NLEV0:NLEV1, NFLD, NGPBLKS)) + +! fill data array + +DO JBLK = 1, NGPBLKS + IIDIA = 1 + IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) + DO JFLD = 1, NFLD + ID1 (:, NLEV0, JFLD, JBLK) = NMISS + ID1 (:, NLEV1, JFLD, JBLK) = NMISS + DO JLEV = 1, NFLEVG + DO JLON = IIDIA, IFDIA + ID1 (JLON, JLEV, JFLD, JBLK) = FUNC (JLON, JLEV, JFLD, JBLK) + ENDDO + DO JLON = IFDIA+1, NPROMA + ID1 (JLON, JLEV, JFLD, JBLK) = NMISS + ENDDO + ENDDO + ENDDO +ENDDO + +CALL FIELD_NEW (YLFID1, DATA=ID1, LBOUNDS=[1, NLEV0, 1, 1]) CALL YL_FGS%INIT (YLTRIG, NGPTOT) +IVALID = COUNT (LLTRIG) + ! get pointer on filtered data IF (JPASS == 1) THEN - ID_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFD) + IDPTR_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFID) + ID1PTR_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFID1) ELSE - ID_FILTERED => GATHER_DEVICE_DATA_RDWR (YL_FGS, YLFD) + IDPTR_FILTERED => GATHER_DEVICE_DATA_RDWR (YL_FGS, YLFID) + ID1PTR_FILTERED => GATHER_DEVICE_DATA_RDWR (YL_FGS, YLFID1) +ENDIF + +! Check sizes + +ISIZE = SIZE (IDPTR_FILTERED, 1) * SIZE (IDPTR_FILTERED, 3) + +IF (.NOT. ((IVALID <= ISIZE) .AND. (ISIZE < IVALID + NPROMA))) THEN + PRINT *, IVALID + PRINT *, ISIZE + PRINT *, IVALID + NPROMA + CALL FIELD_ABORT ("ERROR") +ENDIF + +ISIZE = SIZE (ID1PTR_FILTERED, 1) * SIZE (ID1PTR_FILTERED, 3) + +IF (.NOT. ((IVALID <= ISIZE) .AND. (ISIZE < IVALID + NPROMA))) THEN + PRINT *, IVALID + PRINT *, ISIZE + PRINT *, IVALID + NPROMA + CALL FIELD_ABORT ("ERROR") ENDIF ! update filtered data @@ -83,7 +137,7 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 #ifdef OMPGPU !$OMP TARGET #else -!$ACC SERIAL PRESENT (ID_FILTERED) COPYIN (YL_FGS) IF (JPASS == 2) +!$ACC SERIAL PRESENT (IDPTR_FILTERED, ID1PTR_FILTERED) COPYIN (YL_FGS) IF (JPASS == 2) #endif DO JBLK = 1, YL_FGS%KGPBLKS @@ -91,10 +145,12 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 IFDIA = MERGE (YL_FGS%KLON, YL_FGS%KGPTOT - (JBLK - 1) * YL_FGS%KLON, JBLK < YL_FGS%KGPBLKS) DO JFLD = 1, NFLD DO JLON = IIDIA, IFDIA - ID_FILTERED (JLON, JFLD, JBLK) = NNEW + IDPTR_FILTERED (JLON, JFLD, JBLK) = NNEW + ID1PTR_FILTERED (JLON, JFLD, JBLK) = NNEW ENDDO DO JLON = IFDIA+1, YL_FGS%KLON - ID_FILTERED (JLON, JFLD, JBLK) = NMISS + IDPTR_FILTERED (JLON, JFLD, JBLK) = NMISS + ID1PTR_FILTERED (JLON, JFLD, JBLK) = NMISS ENDDO ENDDO ENDDO @@ -111,7 +167,7 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 ! get data on host for verification -ID1 => GET_HOST_DATA_RDONLY (YLFD) +IDPTR => GET_HOST_DATA_RDONLY (YLFID) DO JBLK = 1, NGPBLKS IIDIA = 1 @@ -122,16 +178,56 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 DO JLON = IIDIA, IFDIA IF (LLTRIG (JLON, JLEV, JBLK)) THEN - IF (ID1 (JLON, JLEV, JFLD, JBLK) /= NNEW) & + IF (IDPTR (JLON, JLEV, JFLD, JBLK) /= NNEW) & + & CALL FIELD_ABORT ("ERROR") + ELSE + IF (IDPTR (JLON, JLEV, JFLD, JBLK) /= FUNC (JLON, JLEV, JFLD, JBLK)) & + & CALL FIELD_ABORT ("ERROR") + ENDIF + ENDDO + + DO JLON = IFDIA+1, NPROMA + IF (IDPTR (JLON, JLEV, JFLD, JBLK) /= NMISS) & + & CALL FIELD_ABORT ("ERROR") + ENDDO + + ENDDO + ENDDO + +ENDDO + +! extra levels + +ID1PTR => GET_HOST_DATA_RDONLY (YLFID1) + +DO JBLK = 1, NGPBLKS + IIDIA = 1 + IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS) + + DO JFLD = 1, NFLD + + IF (ANY (ID1PTR (:, NLEV0, JFLD, JBLK) /= NMISS)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + + IF (ANY (ID1PTR (:, NLEV1, JFLD, JBLK) /= NMISS)) THEN + CALL FIELD_ABORT ("ERROR") + ENDIF + + DO JLEV = 1, NFLEVG + + DO JLON = IIDIA, IFDIA + IF (LLTRIG (JLON, JLEV, JBLK)) THEN + IF (ID1PTR (JLON, JLEV, JFLD, JBLK) /= NNEW) & & CALL FIELD_ABORT ("ERROR") ELSE - IF (ID1 (JLON, JLEV, JFLD, JBLK) /= FUNC (JLON, JLEV, JFLD, JBLK)) & + IF (ID1PTR (JLON, JLEV, JFLD, JBLK) /= FUNC (JLON, JLEV, JFLD, JBLK)) & & CALL FIELD_ABORT ("ERROR") ENDIF ENDDO DO JLON = IFDIA+1, NPROMA - IF (ID1 (JLON, JLEV, JFLD, JBLK) /= NMISS) & + IF (ID1PTR (JLON, JLEV, JFLD, JBLK) /= NMISS) & & CALL FIELD_ABORT ("ERROR") ENDDO @@ -142,11 +238,12 @@ PROGRAM GATHER_SCATTER_COLLAPSE2 ! clear data -NULLIFY (ID1) +NULLIFY (IDPTR, ID1PTR) -CALL FIELD_DELETE (YLFD) +CALL FIELD_DELETE (YLFID) +CALL FIELD_DELETE (YLFID1) -DEALLOCATE (ID) +DEALLOCATE (ID, ID1) CALL FIELD_DELETE (YLTRIG) From 352daac4697bf48f7766c9fa75e491bd4a3b706a Mon Sep 17 00:00:00 2001 From: Philippe Marguinaud Date: Sun, 12 Jul 2026 09:39:31 +0000 Subject: [PATCH 8/8] Return dummy pointer when optional field argument is not present (GET_GATHER_* routines) --- ...NKSUFF_gather_collapseCOLLAPSE_module.fypp | 23 +++++++++++++++++-- src/shuffle/field_RANKSUFF_gather_module.fypp | 13 +++++++++-- 2 files changed, 32 insertions(+), 4 deletions(-) diff --git a/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp b/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp index 7de95605..9fdc73d1 100644 --- a/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp +++ b/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp @@ -67,13 +67,32 @@ END FUNCTION ${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ SUBROUTINE S${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ (SELF, PTR, YLF) +USE FIELD_${RANK}$${SUFF}$_ACCESS_MODULE + CLASS (FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$) :: SELF ${ft.type}$, POINTER :: PTR(${gathered_shape}$) CLASS (${ft.name}$), POINTER, OPTIONAL :: YLF +#:if COLLAPSE == 2 +${ft.type}$, POINTER :: PTR1(${ft.shape}$) +#:endif + +IF (PRESENT (YLF)) THEN + + CALL PAIR_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ (SELF%${ft.name}$_C${COLLAPSE}$LIST, SELF%LNULL, SELF%LFULL, & + & SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, PTR, YLF, SELF%KBLKMIN, SELF%KBLKMAX) + +ELSE + + +#:if COLLAPSE == 2 + CALL SGET_${what}$_DATA_${mode}$ (PTR1, YLF) + PTR => PTR1 (${gathered_shape}$, 1) +#:elif COLLAPSE == 1 + CALL SGET_${what}$_DATA_${mode}$ (PTR, YLF) +#:endif -CALL PAIR_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ (SELF%${ft.name}$_C${COLLAPSE}$LIST, SELF%LNULL, SELF%LFULL, & -& SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, PTR, YLF, SELF%KBLKMIN, SELF%KBLKMAX) +ENDIF END SUBROUTINE S${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$ diff --git a/src/shuffle/field_RANKSUFF_gather_module.fypp b/src/shuffle/field_RANKSUFF_gather_module.fypp index f875085b..89de4b75 100644 --- a/src/shuffle/field_RANKSUFF_gather_module.fypp +++ b/src/shuffle/field_RANKSUFF_gather_module.fypp @@ -60,13 +60,22 @@ END FUNCTION ${ft.name}$_GATHER_${what}$_DATA_${mode}$ SUBROUTINE S${ft.name}$_GATHER_${what}$_DATA_${mode}$ (SELF, PTR, YLF) +USE FIELD_${RANK}$${SUFF}$_ACCESS_MODULE + CLASS (FIELD_SHUFFLE) :: SELF ${ft.type}$, POINTER :: PTR(${ft.shape}$) CLASS (${ft.name}$), POINTER, OPTIONAL :: YLF +IF (PRESENT (YLF)) THEN + + CALL PAIR_GATHER_${what}$_DATA_${mode}$ (SELF%${ft.name}$_LIST, SELF%LNULL, SELF%LFULL, & + & SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, PTR, YLF, SELF%KBLKMIN, SELF%KBLKMAX) + +ELSE + + CALL SGET_${what}$_DATA_${mode}$ (PTR, YLF) -CALL PAIR_GATHER_${what}$_DATA_${mode}$ (SELF%${ft.name}$_LIST, SELF%LNULL, SELF%LFULL, & -& SELF%KLON_G, SELF%KGPBLKS_G, SELF%YLFINDS, PTR, YLF, SELF%KBLKMIN, SELF%KBLKMAX) +ENDIF END SUBROUTINE S${ft.name}$_GATHER_${what}$_DATA_${mode}$