diff --git a/src/shuffle/CMakeLists.txt b/src/shuffle/CMakeLists.txt
index 37ecb1e2..7e7bfcf8 100644
--- a/src/shuffle/CMakeLists.txt
+++ b/src/shuffle/CMakeLists.txt
@@ -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_collapseCOLLAPSE_module.fypp b/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp
new file mode 100644
index 00000000..9fdc73d1
--- /dev/null
+++ b/src/shuffle/field_RANKSUFF_gather_collapseCOLLAPSE_module.fypp
@@ -0,0 +1,105 @@
+#! (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) 
+
+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
+
+ENDIF
+
+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_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}$
 
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_collapseCOLLAPSE_module.fypp b/src/shuffle/field_gathscat_collapseCOLLAPSE_module.fypp
new file mode 100644
index 00000000..6069bfb5
--- /dev/null
+++ b/src/shuffle/field_gathscat_collapseCOLLAPSE_module.fypp
@@ -0,0 +1,59 @@
+#! (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_COLLAPSE${COLLAPSE}$_MODULE
+
+#:set fieldTypeList = fieldType.getFieldTypeList (hasView=True)
+
+USE FIELD_ACCESS_MODULE
+USE FIELD_FACTORY_MODULE
+USE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$_TYPE_MODULE
+${fieldType.useParkind1 ()}$
+
+#:for ft in fieldTypeList
+#:if ft.rank >= COLLAPSE + 1
+USE ${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_MODULE
+#:endif
+#:endfor
+
+
+IMPLICIT NONE
+
+PRIVATE
+
+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 >= COLLAPSE + 1
+  MODULE PROCEDURE ${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${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 >= COLLAPSE + 1
+  MODULE PROCEDURE S${ft.name}$_GATHER_COLLAPSE${COLLAPSE}$_${what}$_DATA_${mode}$
+#:endif
+#:endfor
+END INTERFACE SGATHER_${what}$_DATA_${mode}$
+
+PUBLIC :: SGATHER_${what}$_DATA_${mode}$
+
+#:endfor
+#:endfor
+
+
+END MODULE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$_MODULE
diff --git a/src/shuffle/field_gathscat_collapseCOLLAPSE_type_module.fypp b/src/shuffle/field_gathscat_collapseCOLLAPSE_type_module.fypp
new file mode 100644
index 00000000..27b82e9b
--- /dev/null
+++ b/src/shuffle/field_gathscat_collapseCOLLAPSE_type_module.fypp
@@ -0,0 +1,225 @@
+#! (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_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 >= COLLAPSE + 1
+USE ${ft.name}$_SHUFFLE_COLLAPSE${COLLAPSE}$_MODULE
+#:endif
+#:endfor
+
+IMPLICIT NONE
+
+PRIVATE
+
+TYPE, EXTENDS (FIELD_SHUFFLE) :: FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$
+#:for ft in fieldTypeList
+#: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_COLLAPSE${COLLAPSE}$
+  PROCEDURE :: INIT_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$
+  PROCEDURE :: SCATTER => SCATTER_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$
+END TYPE FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$
+
+PUBLIC :: FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$
+
+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_COLLAPSE${COLLAPSE}$ (SELF, YDFCOND, KGPTOT, KLON_S, KLON_G, KBLKMIN, KBLKMAX)
+
+USE FIELD_ABORT_MODULE
+
+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_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
+#:if COLLAPSE == 2
+INTEGER (KIND=JPIM) :: JLEV
+#:endif
+
+LLF => GET_HOST_DATA_RDONLY (YDFCOND)
+
+SELF%KBLKMIN = LBOUND (LLF, ${COLLAPSE + 1}$)
+IF (PRESENT (KBLKMIN)) SELF%KBLKMIN = KBLKMIN
+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
+
+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
+  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
+
+#: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=[${COLLAPSE + 1}$, 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
+#: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_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
+            JLONG = 1
+            JBLKG = JBLKG + 1
+          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
+  ENDIF
+
+ENDIF
+
+END SUBROUTINE
+
+SUBROUTINE SCATTER_FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$ (SELF)
+CLASS (FIELD_GATHSCAT_COLLAPSE${COLLAPSE}$) :: SELF
+#:for ft in fieldTypeList
+#: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 >= COLLAPSE + 1
+  CALL PAIR_SCATTER_COLLAPSE${COLLAPSE}$_DATA (SELF%${ft.name}$_C${COLLAPSE}$LIST, 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_COLLAPSE${COLLAPSE}$_TYPE_MODULE
diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt
index d44622e6..d5c7dd1b 100644
--- a/tests/CMakeLists.txt
+++ b/tests/CMakeLists.txt
@@ -51,6 +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
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
new file mode 100644
index 00000000..b94053f9
--- /dev/null
+++ b/tests/gather_scatter_collapse2.F90
@@ -0,0 +1,252 @@
+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
+
+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
+
+LOGICAL :: LLTRIG (NPROMA, NFLEVG, NGPBLKS)
+CLASS (FIELD_3LM), POINTER :: YLTRIG => NULL ()
+
+INTEGER (KIND=JPIM), ALLOCATABLE :: ID (:,:,:,:)
+CLASS (FIELD_4IM), POINTER :: YLFID => NULL()
+INTEGER (KIND=JPIM),POINTER :: IDPTR_FILTERED (:,:,:) => NULL (), IDPTR (:,:,:,:) => 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, IVALID, ISIZE
+
+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
+  IIDIA = 1 
+  IFDIA = MERGE (NPROMA, NGPTOT - (JBLK - 1) * NPROMA, JBLK < NGPBLKS)
+  DO JLEV = 1, NFLEVG
+     DO JLON = IIDIA, IFDIA
+       LLTRIG (JLON,JLEV,JBLK) = MOD (JLON+JLEV, 2) == 0
+     ENDDO
+  ENDDO
+ENDDO
+
+CALL FIELD_NEW (YLTRIG, DATA=LLTRIG)
+
+ALLOCATE(ID (NPROMA, NFLEVG, NFLD, NGPBLKS))
+
+! fill data array
+
+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
+        ID (JLON, JLEV, JFLD, JBLK) = FUNC (JLON, JLEV, JFLD, JBLK)
+      ENDDO
+      DO JLON = IFDIA+1, NPROMA
+        ID (JLON, JLEV, JFLD, JBLK) = NMISS
+      ENDDO
+    ENDDO
+  ENDDO
+ENDDO
+
+! 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
+  IDPTR_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFID)
+  ID1PTR_FILTERED => GATHER_HOST_DATA_RDWR (YL_FGS, YLFID1)
+ELSE
+  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
+
+#ifdef OMPGPU
+!$OMP TARGET
+#else
+!$ACC SERIAL PRESENT (IDPTR_FILTERED, ID1PTR_FILTERED) COPYIN (YL_FGS) IF (JPASS == 2)
+#endif
+
+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 JFLD = 1, NFLD
+    DO JLON = IIDIA, IFDIA
+      IDPTR_FILTERED (JLON, JFLD, JBLK) = NNEW
+      ID1PTR_FILTERED (JLON, JFLD, JBLK) = NNEW
+    ENDDO
+    DO JLON = IFDIA+1, YL_FGS%KLON
+      IDPTR_FILTERED (JLON, JFLD, JBLK) = NMISS
+      ID1PTR_FILTERED (JLON, JFLD, JBLK) = NMISS
+    ENDDO
+  ENDDO
+ENDDO
+
+#ifdef OMPGPU
+!$OMP END TARGET
+#else
+!$ACC END SERIAL
+#endif
+
+! scatter back
+
+CALL YL_FGS%SCATTER ()
+
+! get data on host for verification
+
+IDPTR => GET_HOST_DATA_RDONLY (YLFID)
+
+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 (LLTRIG (JLON, JLEV, JBLK)) THEN
+          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 (ID1PTR (JLON, JLEV, JFLD, JBLK) /= FUNC (JLON, JLEV, JFLD, JBLK)) &
+            & CALL FIELD_ABORT ("ERROR")
+        ENDIF
+      ENDDO
+
+      DO JLON = IFDIA+1, NPROMA
+        IF (ID1PTR (JLON, JLEV, JFLD, JBLK) /= NMISS) &
+          & CALL FIELD_ABORT ("ERROR")
+      ENDDO
+      
+    ENDDO
+  ENDDO
+
+ENDDO
+
+! clear data
+
+NULLIFY (IDPTR, ID1PTR)
+
+CALL FIELD_DELETE (YLFID)
+CALL FIELD_DELETE (YLFID1)
+
+DEALLOCATE (ID, ID1)
+
+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