Changeset 3837 for branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/exchmod.F90

Timestamp:

2013-03-12T15:55:32+01:00 (11 years ago)

Author:

trackstand2

Message:

Merge of finiss

File:

• branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/exchmod.F90 (modified) (121 diffs)

branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/exchmod.F90

@@ -11 +11 @@
   ! Make some key parameters from mapcomm_mod available to all who 
   ! USE this module
-  USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE
+  USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE, &
+                         jeub
   IMPLICIT none
 
@@ -63 +64 @@
   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north  ! dim. ndim_rank_north, number
                                                            ! of the procs belonging to ncomm_north
+  LOGICAL, SAVE :: do_nfold ! Whether this PE contributes to N-fold exchange
+                            !  -  takes domain trimming into account.
   INTEGER, PARAMETER :: num_nfold_rows = 4 ! No. of rows at the top of the 
                                            ! global domain to use in applying 
                                            ! the north-fold condition (no value
-                                           ! other than 4 currently supported)
+                                           ! other than 4 currently tested)
+
+  INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nfold_npts ! How many points each
+                                                         ! northern proc contrib
+                                                         ! to nfold exchange
 
 !FTRANS r3dptr :I :I :z
@@ -112 +119 @@
          nrank_north, north_root, ndim_rank_north, &
          ngrp_north, ngrp_world, ncomm_north, &
+         num_nfold_rows, do_nfold, nfold_npts, &
          exchmod_alloc, add_exch, bound_exch_list, &
-         Iminus, Iplus, Jminus, Jplus, NONE, num_nfold_rows, &
-         lbc_exch3, lbc_exch2, & !lbc_exch3i, lbc_exch2i, &
-         MPI_COMM_WORLD, MPI_Wtime
+         Iminus, Iplus, Jminus, Jplus, NONE, &
+         lbc_exch3, lbc_exch2
+
+#if defined key_mpp_mpi
+  PUBLIC MPI_COMM_WORLD, MPI_Wtime
+#endif
 
   ! MPI only
@@ -285 +296 @@
 
   SUBROUTINE bound_exch_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
-       comm1, comm2, comm3, comm4,      &
-       cd_type, lfill, isgn, lzero )
+                                  comm1, comm2, comm3, comm4,      &
+                                  cd_type, lfill, pval, isgn, lzero )
     USE par_oce, ONLY: wp, jpreci, jprecj, jpim1
     USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, &
-         nperio, nbondi, npolj
+                       nperio, nbondi, npolj, narea
     USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc
+    USE mapcomm_mod, ONLY: trimmed, eidx, widx
     IMPLICIT none
     INTEGER, INTENT(in)  :: nhalo,nhexch
@@ -302 +314 @@
     CHARACTER(len=1),  INTENT(in) :: cd_type
     LOGICAL, OPTIONAL, INTENT(in) :: lfill
+    REAL(wp),OPTIONAL, INTENT(in) :: pval  ! background value (used at closed boundaries)
     INTEGER, OPTIONAL, INTENT(in) :: isgn
-    LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to zero halos on closed boundaries
+    LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to set halo values on closed boundaries
     ! Local arguments
     INTEGER :: itag          ! Communication handle
@@ -310 +323 @@
     INTEGER :: ileft, iright ! First and last x-coord of internal points
     INTEGER :: kdim1
+    INTEGER  :: iland ! Land values - zero by default unless pval passed in.
+    REAL(wp) :: zland !  "     "
     LOGICAL :: lfillarg, lzeroarg
     !!--------------------------------------------------------------------
@@ -324 +339 @@
     lfillarg = .FALSE.
     isgnarg = 1
+    zland = 0.0_wp
 
     IF( PRESENT(lfill) ) lfillarg = lfill
     IF( PRESENT(isgn)  ) isgnarg  = isgn
     IF( PRESENT(lzero) ) lzeroarg = lzero
+    IF( PRESENT(pval)  ) zland    = pval 
+    iland=INT(zland)
 
     ! Find out the size of 3rd dimension of the array
@@ -356 +374 @@
        ! have cyclic E-W boundary conditions.
        ileft = nldi
-       IF(ilbext .AND. cyclic_bc)ileft = ileft + 1
+       IF( (ilbext .AND. (.NOT. trimmed(widx,narea))) .AND. cyclic_bc) &
+                                                     ileft = ileft + 1
 
        iright = nlei
-       IF(iubext .AND. cyclic_bc)iright = iright - 1
+       IF( (iubext .AND. (.NOT. trimmed(eidx,narea))) .AND. cyclic_bc) &
+                                                    iright = iright - 1
 
        IF ( PRESENT(b2) ) THEN
@@ -527 +547 @@
        END IF
 
-    ELSE ! lfillarg is .FALSE.
+    ELSE ! lfillarg is .FALSE. - standard closed or cyclic treatment
 
        !                                        ! East-West boundaries
        !                                        ! ====================
+       !   nbondi == 2 when a single sub-domain spans the whole width
+       !   of the global domain
        IF( nbondi == 2 .AND.   &      ! Cyclic east-west
             &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
@@ -568 +590 @@
                 SELECT CASE ( cd_type )
                 CASE ( 'T', 'U', 'V', 'W' , 'I' )
-                   b2(1:jpreci         , :) = 0._wp ! Western halo
-                   b2(nlci-jpreci+1:jpi, :) = 0._wp ! Eastern halo
+                   b2(1:jpreci         , :) = zland ! Western halo
+                   b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo
                 CASE ( 'F' )
-                   b2(nlci-jpreci+1:jpi, :) = 0._wp ! Eastern halo
+                   b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo
                 END SELECT
              ELSE IF ( PRESENT(ib2) ) THEN
                 SELECT CASE ( cd_type )
                 CASE ( 'T', 'U', 'V', 'W' , 'I' )
-                   ib2(1:jpreci         , :) = 0 ! Western halo
-                   ib2(nlci-jpreci+1:jpi, :) = 0 ! Eastern halo
+                   ib2(1:jpreci         , :) = iland ! Western halo
+                   ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo
                 CASE ( 'F' )
-                   ib2(nlci-jpreci+1:jpi, :) = 0 ! Eastern halo
+                   ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo
                 END SELECT
              ELSE IF ( PRESENT(b3) ) THEN
@@ -588 +610 @@
                       DO ji=1,jpreci,1
                          DO jk=1,jpk,1
-                            b3(ji, jj, jk) = 0._wp
+                            b3(ji, jj, jk) = zland
                          END DO
                       END DO
                       DO ji=nlci-jpreci+1,jpi,1
                          DO jk=1,jpk,1
-                            b3(ji, jj, jk) = 0._wp
+                            b3(ji, jj, jk) = zland
                          END DO
                       END DO
                    END DO
 #else
-                   b3(1:jpreci         , :, :) = 0._wp
-                   b3(nlci-jpreci+1:jpi, :, :) = 0._wp
+                   b3(1:jpreci         , :, :) = zland
+                   b3(nlci-jpreci+1:jpi, :, :) = zland
 #endif
                 CASE ( 'F' )
@@ -606 +628 @@
                       DO ji = nlci-jpreci+1,jpi,1
                          DO jk = 1,jpk,1
-                            b3(ji, jj, jk) = 0._wp
+                            b3(ji, jj, jk) = zland
                          END DO
                       END DO
                    END DO
 #else
-                   b3(nlci-jpreci+1:jpi, :, :) = 0._wp
+                   b3(nlci-jpreci+1:jpi, :, :) = zland
 #endif
                 END SELECT
@@ -617 +639 @@
                 SELECT CASE ( cd_type )
                 CASE ( 'T', 'U', 'V', 'W' )
-                   ib3(1:jpreci         , :, :) = 0
-                   ib3(nlci-jpreci+1:jpi, :, :) = 0
+                   ib3(1:jpreci         , :, :) = iland
+                   ib3(nlci-jpreci+1:jpi, :, :) = iland
                 CASE ( 'F' )
-                   ib3(nlci-jpreci+1:jpi, :, :) = 0
+                   ib3(nlci-jpreci+1:jpi, :, :) = iland
                 END SELECT
              END IF
@@ -630 +652 @@
        IF( lzeroarg )THEN
 
-          !                                        ! North-South boundaries
-          !                                        ! ======================
+          !                             ! North-South boundaries (always closed)
+          !                             ! ======================
           IF ( PRESENT(b2) ) THEN
              SELECT CASE ( cd_type )
              CASE ( 'T', 'U', 'V', 'W' , 'I' )
-                b2(:,1:nldj-1         ) = 0._wp
-                b2(:,nlcj-jprecj+1:jpj) = 0._wp
+                !b2(:,1:nldj-1         ) = zland
+                ! Below is what is done in original lib_mpp.F90
+                b2(:,1:jprecj         ) = zland
+                b2(:,nlcj-jprecj+1:jpj) = zland
              CASE ( 'F' )
-                b2(:,nlcj-jprecj+1:jpj) = 0._wp
+                b2(:,nlcj-jprecj+1:jpj) = zland
              END SELECT
           ELSE IF ( PRESENT(ib2) ) THEN
              SELECT CASE ( cd_type )
              CASE ( 'T', 'U', 'V', 'W' , 'I' )
-                ib2(:,1:jprecj         ) = 0
-                ib2(:,nlcj-jprecj+1:jpj) = 0
+                ib2(:,1:jprecj         ) = iland
+                ib2(:,nlcj-jprecj+1:jpj) = iland
              CASE ( 'F' )
-                ib2(:,nlcj-jprecj+1:jpj) = 0
+                ib2(:,nlcj-jprecj+1:jpj) = iland
              END SELECT
           ELSE IF ( PRESENT(b3) ) THEN
@@ -652 +676 @@
              CASE ( 'T', 'U', 'V', 'W' )
 #if defined key_z_first
-                DO jj=1,nldj-1,1
+                DO jj=1,jprecj,1
                    DO ji=1,jpi,1
                       DO jk = 1,jpk,1
-                         b3(ji, jj, jk) = 0._wp
+                         b3(ji, jj, jk) = zland
                       END DO
                    END DO
@@ -662 +686 @@
                    DO ji=1,jpi,1
                       DO jk = 1,jpk,1
-                         b3(ji, jj, jk) = 0._wp
+                         b3(ji, jj, jk) = zland
                       END DO
                    END DO
                 END DO
 #else
-                b3(:, 1:nldj-1         , :) = 0._wp
-                b3(:, nlcj-jprecj+1:jpj, :) = 0._wp
+                b3(:, 1:jprecj         , :) = zland
+                b3(:, nlcj-jprecj+1:jpj, :) = zland
 #endif
              CASE ( 'F' )
@@ -675 +699 @@
                    DO ji=1,jpi,1
                       DO jk = 1,jpk,1
-                         b3(ji, jj, jk) = 0._wp
+                         b3(ji, jj, jk) = zland
                       END DO
                    END DO
                 END DO
 #else
-                b3(:, nlcj-jprecj+1:jpj, :) = 0._wp
+                b3(:, nlcj-jprecj+1:jpj, :) = zland
 #endif
              END SELECT
@@ -686 +710 @@
              SELECT CASE ( cd_type )
              CASE ( 'T', 'U', 'V', 'W' )
-                ib3(:, 1:jprecj         , :) = 0
-                ib3(:, nlcj-jprecj+1:jpj, :) = 0
+                ib3(:, 1:jprecj         , :) = iland
+                ib3(:, nlcj-jprecj+1:jpj, :) = iland
              CASE ( 'F' )
-                ib3(:, nlcj-jprecj+1:jpj, :) = 0
+                ib3(:, nlcj-jprecj+1:jpj, :) = iland
              END SELECT
           END IF
@@ -726 +750 @@
        ! We only need to repeat the East and West halo swap if there
        ! IS a north-fold in the configuration.
-       SELECT CASE (npolj)
-
-       CASE ( 3, 4, 5, 6 )
-
-          ! Update East and West halos as required
+       !SELECT CASE (npolj)
+
+       !CASE ( 3, 4, 5, 6 )
+       IF(ndim_rank_north > 0)THEN
+
+          ! Update East and West halos as required - no data sent north
+          ! as it's only the northern-most PEs that have been affected 
+          ! by the north-fold condition.
           ! ARPDBG - inefficient since all PEs do halo swap and only 
           ! those affected by the north fold actually need to - can 
           ! this be done within apply_north_fold?
           CALL exchs_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, &
-               nhexch=nhexch, handle=itag,               &
-               comm1=Iplus,comm2=Iminus,comm3=NONE,comm4=NONE, &
-               cd_type=cd_type, lfill=lfillarg)
+                              nhexch=nhexch, handle=itag,               &
+                              comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
+                              cd_type=cd_type, lfill=lfillarg)
 
           !CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, &
@@ -743 +770 @@
           !                    comm1=Iplus,comm2=Iminus,comm3=NONE,comm4=NONE)
           !                           comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 )
-       END SELECT    ! npolj 
+       END IF        ! ndim_rank_north > 0
+       !END SELECT    ! npolj 
 
     END IF
@@ -1160 +1188 @@
 
        DO ifield = 1, nfields, 1
-          IF( npolj /= 0 )THEN ! only for northern procs.
+          IF( npolj /= 0 .AND. do_nfold )THEN ! only for northern procs.
 
              IF(ASSOCIATED(list(ifield)%r2dptr))THEN
@@ -1180 +1208 @@
        END DO
 
-!!$       IF( npolj /= 0 ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs.
+!!$       IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs.
 
     END SELECT   ! jpni
@@ -1943 +1971 @@
 
     CASE DEFAULT   ! more than 1 proc along I
-       IF( npolj /= 0 )   CALL mpp_lbc_north( b2, cd_type, psgn )   ! only for northern procs.
+       IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north( b2, cd_type, psgn )   ! only for northern procs.
 
     END SELECT   ! jpni
@@ -2074 +2102 @@
 
     CASE DEFAULT   ! more than 1 proc along I
-       IF( npolj /= 0 )   CALL mpp_lbc_north( ib2, cd_type, isgn )   ! only for northern procs.
+       IF( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north( ib2, cd_type, isgn )   ! only for northern procs.
 
     END SELECT   ! jpni
@@ -2285 +2313 @@
 
     CASE DEFAULT ! more than 1 proc along I
-       IF ( npolj /= 0 ) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs.
+       IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs.
 
     END SELECT ! jpni 
@@ -2493 +2521 @@
 
     CASE DEFAULT ! more than 1 proc along I
-       IF ( npolj /= 0 ) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs.
+       IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs.
 
     END SELECT ! jpni 
@@ -2557 +2585 @@
     ELSE
        ! This section is both for error checking and allows me to be lazy in the 
-       ! testing code - I don't have to check which arrays I've been passed.
+       ! testing code - I don't have to check which arrays I've been passed 
+       ! before I call this routine.
        WRITE (*,*) 'WARNING: add_exch called without a ptr to an array - will be ignored'
        RETURN
@@ -2588 +2617 @@
    SUBROUTINE bound_exch2 (b, nhalo, nhexch,           &
                            comm1, comm2, comm3, comm4, &
-                           cd_type, lfill, isgn, lzero )
+                           cd_type, lfill, pval, isgn, lzero )
       !!----------------------------------------------------------------------
       !!----------------------------------------------------------------------
@@ -2600 +2629 @@
       INTEGER, OPTIONAL, INTENT(in) :: isgn
       LOGICAL, OPTIONAL, INTENT(in) :: lzero
+      REAL(wp),OPTIONAL, INTENT(in) :: pval
 
       CALL bound_exch_generic( b2=b,nhalo=nhalo,nhexch=nhexch, &
               comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
-              cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero )
+              cd_type=cd_type, lfill=lfill, pval=pval,         &
+              isgn=isgn, lzero=lzero )
       RETURN
    END SUBROUTINE bound_exch2
@@ -2609 +2640 @@
 
    SUBROUTINE bound_exch2i (b, nhalo, nhexch, comm1, comm2, comm3, comm4, &
-                            cd_type, lfill, isgn, lzero )
+                            cd_type, lfill, pval, isgn, lzero )
       !!----------------------------------------------------------------------
       !!----------------------------------------------------------------------
@@ -2621 +2652 @@
       INTEGER, OPTIONAL, INTENT(in) :: isgn
       LOGICAL, OPTIONAL, INTENT(in) :: lzero
+      REAL(wp),OPTIONAL, INTENT(in) :: pval
 
       CALL bound_exch_generic (ib2=b,nhalo=nhalo,nhexch=nhexch,           &
                          comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
-                         cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero )
+                         cd_type=cd_type, lfill=lfill, pval=pval,         &
+                         isgn=isgn, lzero=lzero )
       RETURN
    END SUBROUTINE bound_exch2i
@@ -2630 +2663 @@
 
    SUBROUTINE bound_exch3 (b, nhalo, nhexch, comm1, comm2, comm3, &
-                          comm4, cd_type, lfill, isgn, lzero)
+                          comm4, cd_type, lfill, pval, isgn, lzero)
       !!----------------------------------------------------------------------
       !!----------------------------------------------------------------------
@@ -2642 +2675 @@
       INTEGER, OPTIONAL, INTENT(in) :: isgn
       LOGICAL, OPTIONAL, INTENT(in) :: lzero
+      REAL(wp),OPTIONAL, INTENT(in) :: pval
 
       CALL bound_exch_generic ( b3=b,nhalo=nhalo,nhexch=nhexch,&
               comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
-              cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero )
+              cd_type=cd_type, lfill=lfill, pval=pval,         &
+              isgn=isgn, lzero=lzero )
       RETURN
    END SUBROUTINE bound_exch3
@@ -2651 +2686 @@
 
    SUBROUTINE bound_exch3i (b, nhalo, nhexch, comm1, comm2, comm3, &
-                           comm4, cd_type, lfill, isgn, lzero)
+                           comm4, cd_type, lfill, pval, isgn, lzero)
       !!----------------------------------------------------------------------
       !!----------------------------------------------------------------------
@@ -2662 +2697 @@
       INTEGER, OPTIONAL, INTENT(in) :: isgn
       LOGICAL, OPTIONAL, INTENT(in) :: lzero
+      REAL(wp),OPTIONAL, INTENT(in) :: pval
 
       CALL bound_exch_generic ( ib3=b,nhalo=nhalo,nhexch=nhexch, &
                 comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
-                cd_type=cd_type, lfill=lfill, isgn=isgn, lzero=lzero )
+                cd_type=cd_type, lfill=lfill, pval=pval,         &
+                isgn=isgn, lzero=lzero )
 
    END SUBROUTINE bound_exch3i
@@ -2695 +2732 @@
       LOGICAL :: lfill
 
-      ! ARPDBG - don't know whether pval currently maps into exchmod framework
-      IF(PRESENT(pval))THEN
-         CALL ctl_stop('STOP','lbc_exch2: got pval argument - NOT IMPLEMENTED')
-         RETURN
-      END IF
-
       lfill = .FALSE.
       IF(PRESENT(cd_mpp))THEN
@@ -2708 +2739 @@
       CALL bound_exch_generic( b2=pt2d,nhalo=jpreci,nhexch=jpreci, &
             comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
-            cd_type=cd_type, lfill=lfill, isgn=INT(psgn), lzero=lzero )
+            cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), &
+            lzero=lzero )
 
    END SUBROUTINE lbc_exch2
@@ -2731 +2763 @@
       LOGICAL :: lfill
 
-      ! ARPDBG - don't know whether pval currently maps into exchmod framework
-      IF(PRESENT(pval))THEN
-         CALL ctl_stop('STOP','lbc_exch3: got pval argument - NOT IMPLEMENTED')
-         RETURN
-      END IF
-
       lfill = .FALSE.
       IF(PRESENT(cd_mpp))THEN
@@ -2742 +2768 @@
       END IF
 
-      CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci,&
-             comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
-             cd_type=cd_type, lfill=lfill, isgn=INT(psgn), lzero=lzero )
+      CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci, &
+             comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus,       &
+             cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), &
+             lzero=lzero )
 
    END SUBROUTINE lbc_exch3
@@ -2773 +2800 @@
     USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus,       &
                            IminusJminus, IplusJminus, IminusJplus,  &
-                           nsend, nxsend, nysend, nxsendp,nysendp,nsendp, &
+                           nsend, nxsend, nysend, nxsendp,nysendp,nzsendp, &
+                           nsendp, &
                            destination,dirsend, dirrecv,                  &
                            isrcsendp,jsrcsendp, idesrecvp, jdesrecvp,     &
-                           nrecv, nxrecv,nyrecv,nxrecvp,nyrecvp,nrecvp,   &
+                           nrecv,  &
+                           nxrecvp,nyrecvp,nzrecvp, nrecvp, nrecvp2d,  &
                            source, iesub, jesub,  &
                            MaxCommDir, MaxComm, cyclic_bc,      &
                            nrecvp, npatchsend, npatchrecv
-    USE lib_mpp,     ONLY: mpi_comm_opa, ctl_stop
+    USE lib_mpp,     ONLY: ctl_stop
+#if defined key_mpp_mpi
+    USE lib_mpp,     ONLY: mpi_comm_opa
+#endif
 #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
     USE dom_oce,     ONLY: narea
@@ -2793 +2825 @@
 
     LOGICAL :: enabled(0:MaxCommDir, maxExchItems)
-    INTEGER :: ides, ierr, irecv, isend, &
-               isrc, jdes, jsrc, nxr, nyr,        &
-               nxs, nys, tag, tag_orig,           &
+    INTEGER :: ides, ierr, irecv, isend,        &
+               isrc, jdes, jsrc, tag, tag_orig, &
                ibeg, iend, jbeg, jend
     INTEGER :: i, j, k, ic, ifield, ipatch ! Loop counters
@@ -2801 +2832 @@
     INTEGER :: npacked
     INTEGER :: handle
+#if defined key_mpp_mpi
     INTEGER :: status(MPI_status_size)
     INTEGER :: astatus(MPI_status_size,MaxComm)
+#endif
     INTEGER :: r2dcount, r3dcount, i2dcount, i3dcount
     ! Indices into int and real copy buffers
@@ -2826 +2859 @@
 #endif
 
-    CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat)
+    !CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat)
 
     ! Allocate a communications tag/handle and a flags array.
@@ -2841 +2874 @@
        ! Check halo width is in range.
        IF ( list(ifield)%halo_width.GT.jpreci ) THEN
-          CALL ctl_stop('STOP','exchs: halo width greater than maximum')
+          CALL ctl_stop('STOP', &
+                        'exchs_generic_list: halo width greater than maximum')
           RETURN
        ENDIF
@@ -2881 +2915 @@
     IF( have_real_field )THEN
 
-       ALLOCATE(recvBuff(jpkdta*maxrecvpts*nfields,nrecv),stat=ierr)
+       ALLOCATE(recvBuff(maxrecvpts*nfields,nrecv),stat=ierr)
        !WRITE(*,"('Allocated ',I7,' reals for recv buff')") &
        !                                 jpkdta*maxrecvpts*nfields
@@ -2898 +2932 @@
     IF( have_int_field .AND. (ierr == 0) )THEN
 
-       ALLOCATE(recvIBuff(jpkdta*maxrecvpts*nfields,nrecv),stat=ierr)
+       ALLOCATE(recvIBuff(maxrecvpts*nfields,nrecv),stat=ierr)
        !WRITE(*,"('Allocated ',I7,' ints for recv buff')") &
        !                                 jpkdta*maxrecvpts*nfields
@@ -2927 +2961 @@
        i3dcount = 0
 
-       IF(source(irecv).GE.0 .AND. nrecvp(irecv,1).GT.0 ) THEN
+       IF( source(irecv).GE.0 .AND. &
+           ( (nrecvp(irecv,1) > 0) .OR. (nrecvp2d(irecv,1) > 0) ) ) THEN
 
           ! This loop is to allow for different fields to have different
@@ -2935 +2970 @@
              IF ( enabled(dirrecv(irecv), ifield) ) THEN
                 IF( ASSOCIATED(list(ifield)%r2dptr) )THEN
-                   r2dcount = r2dcount + 1
+                   r2dcount = r2dcount + nrecvp2d(irecv,1)
                 ELSE IF( ASSOCIATED(list(ifield)%i2dptr) )THEN
-                   i2dcount = i2dcount + 1
+                   i2dcount = i2dcount + nrecvp2d(irecv,1)
                 ELSE IF( ASSOCIATED(list(ifield)%r3dptr) )THEN
                    ! Allow for varying size of third dimension
-                   r3dcount = r3dcount + SIZE(list(ifield)%r3dptr, index_z)
+                   r3dcount = r3dcount + nrecvp(irecv,1)
                 ELSE IF( ASSOCIATED(list(ifield)%i3dptr) )THEN
                    ! Allow for varying size of third dimension
-                   i3dcount = i3dcount + SIZE(list(ifield)%i3dptr, index_z)
+                   i3dcount = i3dcount + nrecvp(irecv,1)
                 END IF
              END IF
@@ -2957 +2992 @@
 
           IF ( r2dcount > 0 .OR. r3dcount > 0 ) THEN
-             CALL MPI_irecv (recvBuff(1,irecv),((r2dcount+r3dcount)*nrecvp(irecv,1)),     &
+             CALL MPI_irecv (recvBuff(1,irecv),(r2dcount+r3dcount),     &
                              MPI_DOUBLE_PRECISION, source(irecv), tag, mpi_comm_opa, &
                              exch_flags(handle,irecv,indexr), ierr)
           END IF
           IF ( i2dcount > 0 .OR. i3dcount > 0 ) THEN
-             CALL MPI_irecv (recvIBuff(1,irecv),((i2dcount+i3dcount)*nrecvp(irecv,1)),       &
+             CALL MPI_irecv (recvIBuff(1,irecv),(i2dcount+i3dcount),       &
                              MPI_INTEGER, source(irecv),tag, mpi_comm_opa, &
                              exch_flags(handle,irecv,indexr),ierr)
@@ -2993 +3028 @@
 
     ierr = 0
-    newSize = jpkdta*maxsendpts*nfields
+    newSize = maxsendpts*nfields
     IF( have_real_field .AND. newSize > sendBuffSize)THEN
        sendBuffSize=newSize
@@ -3010 +3045 @@
 
     IF (ierr .ne. 0) THEN
-       WRITE(*,*) 'ARPDBG: failed to allocate send buf'
        CALL ctl_stop('STOP','exchs_generic_list: unable to allocate send buff')
     END IF
@@ -3111 +3145 @@
                       DO j=jbeg, jend, 1
                          DO i=ibeg, iend, 1
-                            DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
-#else
-                      DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
+                            !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
+                            DO k=1, nzsendp(ipatch,isend,1), 1
+#else
+                      !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
+                      DO k=1, nzsendp(ipatch,isend,1), 1
                          DO j=jbeg, jend, 1
                             DO i=ibeg, iend, 1
@@ -3124 +3160 @@
                    
                       npacked =  nxsendp(ipatch,isend,1) * &
-                                 nysendp(ipatch,isend,1)
-                      rstart   = rstart + npacked*SIZE(list(ifield)%r3dptr, index_z)
-                      r3dcount = r3dcount + npacked*SIZE(list(ifield)%r3dptr, index_z)
+                                 nysendp(ipatch,isend,1) * &
+                                 nzsendp(ipatch,isend,1)
+                      rstart   = rstart + npacked
+                      r3dcount = r3dcount + npacked
+
                    END DO pack_patches3r
 
@@ -3143 +3181 @@
                       DO j=jbeg, jend, 1
                          DO i=ibeg, iend, 1
-                            DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
-#else
-                      DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
+                            !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
+                            DO k=1, nzsendp(ipatch,isend,1), 1
+#else
+                      !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
+                      DO k=1, nzsendp(ipatch,isend,1), 1
                          DO j=jbeg, jend, 1
                             DO i=ibeg, iend, 1
@@ -3155 +3195 @@
                       END DO
 
-                      istart   = istart +  nxs*nys*SIZE(list(ifield)%i3dptr, index_z)
-                      i3dcount = i3dcount + nxs*nys*SIZE(list(ifield)%i3dptr, index_z)
+                      npacked = nxsendp(ipatch,isend,1)* &
+                                nysendp(ipatch,isend,1)* &
+                                nzsendp(ipatch,isend,1)
+                      istart   = istart +  npacked
+                      i3dcount = i3dcount + npacked
                    END DO pack_patches3i
 
@@ -3172 +3215 @@
           ! Now do the send(s) for all fields
           IF(r2dcount > 0 .OR. r3dcount > 0 )THEN
-             CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount),MPI_DOUBLE_PRECISION, &
-                            destination(isend),tag,mpi_comm_opa, &
+             CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount), &
+                            MPI_DOUBLE_PRECISION,                  &
+                            destination(isend),tag,mpi_comm_opa,   &
                             exch_flags(handle,isend,indexs),ierr)
           END IF
@@ -3228 +3272 @@
 
                 ! Increment starting index for next field data in buffer
-                rstart = rstart + nrecvp(irecv,1)
+                rstart = ic + 1 !rstart + nrecvp(irecv,1)
 
              ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
@@ -3250 +3294 @@
 
                 ! Increment starting index for next field data in buffer
-                istart = istart + nrecvp(irecv,1)
+                istart = ic + 1 !istart + nrecvp(irecv,1)
 
              ELSE IF (ASSOCIATED(list(ifield)%r3dptr) ) THEN
@@ -3264 +3308 @@
                    DO j=jbeg, jend, 1
                       DO i=ibeg, iend, 1
-                         DO k=1,SIZE(list(ifield)%r3dptr, index_z), 1
-#else
-                   DO k=1,  SIZE(list(ifield)%r3dptr, index_z), 1
+                         DO k=1, nzrecvp(ipatch,irecv,1), 1
+#else
+                   DO k=1, nzrecvp(ipatch,irecv,1), 1
                       DO j=jbeg, jend, 1
                          DO i=ibeg, iend, 1
@@ -3278 +3322 @@
 
                 ! Increment starting index for next field data in buffer
-                rstart = rstart + nrecvp(irecv,1)*SIZE(list(ifield)%r3dptr,index_z)
+                rstart = ic + 1 ! rstart + nrecvp(irecv,1) !*SIZE(list(ifield)%r3dptr,index_z)
 
              ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
@@ -3292 +3336 @@
                    DO j=jbeg, jend, 1
                       DO i=ibeg, iend, 1
-                         DO k=1,SIZE(list(ifield)%i3dptr,index_z),1
-#else
-                   DO k=1,SIZE(list(ifield)%i3dptr,index_z),1
+                         DO k=1,nzrecvp(ipatch,irecv,1),1
+#else
+                   DO k=1,nzrecvp(ipatch,irecv,1),1
                       DO j=jbeg, jend, 1
                          DO i=ibeg, iend, 1
@@ -3306 +3350 @@
 
                 ! Increment starting index for next field data in buffer
-                istart = istart + nrecvp(irecv,1)*SIZE(list(ifield)%i3dptr,index_z)
+                istart = ic + 1 !istart + nrecvp(irecv,1) !*SIZE(list(ifield)%i3dptr,index_z)
 
              END IF
@@ -3395 +3439 @@
     CALL free_exch_handle(handle)
 
-    CALL prof_region_end(ARPEXCHS_LIST, iprofStat)
+    !CALL prof_region_end(ARPEXCHS_LIST, iprofStat)
     
   END SUBROUTINE exchs_generic_list
@@ -3431 +3475 @@
     ! *******************************************************************
     USE par_oce,     ONLY: wp, jpreci, jprecj, jpni, jpkdta
-    USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, &
-                           IminusJminus, IplusJminus, IminusJplus,   &
-                           nrecv, nsend, nrecvp, nsendp, nxsend,nysend,&
-                           destination,dirsend, dirrecv, &
-                           isrcsend, jsrcsend, idesrecv, jdesrecv, &
-                           isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, &
-                           nxrecv,nyrecv,source, iesub, jesub, &
-                           MaxCommDir, MaxComm, idessend, jdessend, &
-                           nxsendp, nysendp, nxrecvp, nyrecvp,      &
-                           npatchsend, npatchrecv, &
-                           cyclic_bc
-    USE lib_mpp,     ONLY: mpi_comm_opa, ctl_stop
+    USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus,   &
+                           IminusJminus, IplusJminus, IminusJplus,     &
+                           nrecv, nsend, nrecvp, nsendp,               &
+                           nrecvp2d, nsendp2d,  nxsend, nysend,        &
+                           destination,dirsend, dirrecv,               &
+                           isrcsend, jsrcsend, idesrecv, jdesrecv,     &
+                           isrcsendp,jsrcsendp,idesrecvp,jdesrecvp,    &
+                           nxrecv,source, iesub, jesub,         &
+                           MaxCommDir, MaxComm, idessend, jdessend,    &
+                           nxsendp, nysendp, nzsendp,                  &
+                           nxrecvp, nyrecvp, nzrecvp,                  &
+                           npatchsend, npatchrecv, cyclic_bc
+    USE lib_mpp,     ONLY: ctl_stop
+#if defined key_mpp_mpi
+    USE lib_mpp,     ONLY: mpi_comm_opa
+#endif
     USE dom_oce,     ONLY: narea
     USE in_out_manager, ONLY: numout
@@ -3474 +3522 @@
     INTEGER :: index  ! To hold index returned from MPI_waitany
     INTEGER, DIMENSION(3) :: isubsizes, istarts ! isizes
+#if defined key_mpp_mpi
     INTEGER :: status(MPI_status_size)
     INTEGER :: astatus(MPI_status_size,MaxComm)
+#endif
     LOGICAL, SAVE :: first_time = .TRUE.
 #if defined key_z_first
@@ -3489 +3539 @@
 
     !CALL prof_region_begin(ARPEXCHS_GENERIC, "Exchs_indiv", iprofStat)
-!    CALL timing_start('exchs_generic')
+    !CALL timing_start('exchs_generic')
 
     ierr = 0
 
-    ! Find out the sizes of the arrays.
-
-    kdim1 = 1
-    IF ( PRESENT(b3) ) THEN
-       kdim1 = SIZE(b3,dim=index_z)
-    ELSEIF ( PRESENT(ib3) ) THEN
-       kdim1 = SIZE(ib3,dim=index_z)
-    ELSEIF ( PRESENT(b2) ) THEN
-       kdim1 = SIZE(b2,dim=2)
-    ELSEIF ( PRESENT(ib2) ) THEN
-       kdim1 = SIZE(ib2,dim=2)
-    ENDIF
-
     ! Check nhexch is in range.
 
     IF ( nhexch.GT.jpreci ) THEN
-       STOP 'exchs: halo width greater than maximum'
+       CALL ctl_stop('STOP','exchs: halo width greater than maximum')
     ENDIF
 
@@ -3544 +3581 @@
        IF(.NOT. ALLOCATED(sendBuff))THEN
           ! Only allocate the sendBuff once
-          ALLOCATE(recvBuff(jpkdta*maxrecvpts,nrecv), &
-                   sendBuff(jpkdta*maxsendpts,nsend),stat=ierr)
+          ALLOCATE(recvBuff(maxrecvpts,nrecv), &
+                   sendBuff(maxsendpts,nsend),stat=ierr)
        ELSE
-          ALLOCATE(recvBuff(jpkdta*maxrecvpts,nrecv),stat=ierr)
+          ALLOCATE(recvBuff(maxrecvpts,nrecv),stat=ierr)
        END IF
     ELSE IF(PRESENT(ib2) .OR. PRESENT(ib3))THEN
        IF(.NOT. ALLOCATED(sendIBuff))THEN
-          ALLOCATE(recvIBuff(jpkdta*maxrecvpts,nrecv), &
-                   sendIBuff(jpkdta*maxsendpts,nsend),stat=ierr)
+          ALLOCATE(recvIBuff(maxrecvpts,nrecv), &
+                   sendIBuff(maxsendpts,nsend),stat=ierr)
        ELSE
-          ALLOCATE(recvIBuff(jpkdta*maxrecvpts,nrecv),stat=ierr)
+          ALLOCATE(recvIBuff(maxrecvpts,nrecv),stat=ierr)
        END IF
     END IF
@@ -3578 +3615 @@
           !          that isn't used
           IF ( PRESENT(b2) ) THEN
-             CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1),   &
+             CALL MPI_irecv (recvBuff(1,irecv),nrecvp2d(irecv,1), &
                              MPI_DOUBLE_PRECISION, source(irecv), &
                              tag, mpi_comm_opa,                   &
                              exch_flags(handle,irecv,indexr), ierr)
           ELSEIF ( PRESENT(ib2) ) THEN
+             CALL MPI_irecv (recvIBuff(1,irecv),nrecvp2d(irecv,1), &
+                             MPI_INTEGER, source(irecv),         &
+                             tag, mpi_comm_opa,                  &
+                             exch_flags(handle,irecv,indexr),ierr)
+          ELSEIF ( PRESENT(b3) ) THEN
+             CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1),   &
+                             MPI_DOUBLE_PRECISION, source(irecv), &
+                             tag, mpi_comm_opa,                   &
+                             exch_flags(handle,irecv,indexr),ierr)
+          ELSEIF ( PRESENT(ib3) ) THEN
              CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1), &
                              MPI_INTEGER, source(irecv),         &
                              tag, mpi_comm_opa,                  &
                              exch_flags(handle,irecv,indexr),ierr)
-          ELSEIF ( PRESENT(b3) ) THEN
-             CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1)*kdim1,   &
-                             MPI_DOUBLE_PRECISION, source(irecv), &
-                             tag, mpi_comm_opa,                   &
-                             exch_flags(handle,irecv,indexr),ierr)
-          ELSEIF ( PRESENT(ib3) ) THEN
-             CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1)*kdim1, &
-                             MPI_INTEGER, source(irecv),         &
-                             tag, mpi_comm_opa,                  &
-                             exch_flags(handle,irecv,indexr),ierr)
           ENDIF
-          IF ( ierr.NE.0 ) THEN
-             WRITE (numout,*) 'ARPDBG - irecv hit error'
-             CALL flush(numout)
-             CALL MPI_abort(mpi_comm_opa,1,ierr)
-          END IF
+          ! No point checking for MPI errors because default MPI error handler
+          ! aborts run without returning control to calling program.
+          !IF ( ierr.NE.0 ) THEN
+          !   WRITE (numout,*) 'ARPDBG - irecv hit error'
+          !   CALL flush(numout)
+          !   CALL MPI_abort(mpi_comm_opa,1,ierr)
+          !END IF
 
 #if defined DEBUG_COMMS
           WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' src = ',I3,' tag = ',I4,' npoints = ',I6)") &
                   narea-1,handle,dirrecv(irecv), &
-                  source(irecv), tag, nrecvp(irecv,1)*kdim1
+                  source(irecv), tag, nrecvp(irecv,1)
 #endif
 
@@ -3635 +3674 @@
 
        IF ( enabled(dirsend(isend)) .AND. &
-            destination(isend).GE.0 .AND. nxsend(isend).GT.0 ) THEN
+            destination(isend) >= 0 .AND. nxsend(isend) > 0 ) THEN
 
           isrc = isrcsend(isend)
@@ -3647 +3686 @@
           IF(PRESENT(b3))THEN
              WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &  
-               narea-1, handle, tag, destination(isend),nsendp(isend,1)*kdim1,dirsend(isend)
+               narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend)
           ELSE IF(PRESENT(b2))THEN
              WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &  
-               narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend)
+               narea-1, handle, tag, destination(isend),nsendp2d(isend,1),dirsend(isend)
           END IF
 #endif
@@ -3673 +3712 @@
                 END DO
 
+!!$                ! For 'stupid' compiler that refuses to do a memcpy for above
 !!$                CALL do_real8_copy( nxsendp(patch,isend,1)*nysendp(patch,isend,1), &
 !!$                                    b2(istart,jstart),                             &
@@ -3709 +3749 @@
           ELSEIF ( PRESENT(b3) )THEN
 
-!             CALL timing_start('3dr_pack')
+             ! CALL timing_start('3dr_pack')
              ic = 0
              pack_patches3r: DO ipatch=1,npatchsend(isend,1)
@@ -3720 +3760 @@
                 DO j=jstart, jend, 1
                    DO i=istart, iend, 1
-                      DO k=1,kdim1,1
-#else
-                DO k=1,kdim1,1
+                      DO k=1,nzsendp(ipatch,isend,1),1
+#else
+                DO k=1,nzsendp(ipatch,isend,1),1
                    DO j=jstart, jend, 1
                       DO i=istart, iend, 1
@@ -3732 +3772 @@
                 END DO
              END DO pack_patches3r
-!             CALL timing_stop('3dr_pack')
+
+             ! CALL timing_stop('3dr_pack')
 
              CALL MPI_Isend(sendBuff(1,isend),ic,                  &
@@ -3740 +3781 @@
 
 #if defined DEBUG_COMMS
-          WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &
+             WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &
                      narea-1, npatchsend(isend,1),ic, &
                      destination(isend)
@@ -3756 +3797 @@
                  DO j=jstart, jend, 1
                     DO i=istart, iend, 1
-                       DO k=1,kdim1,1
-#else
-                 DO k=1,kdim1,1
+                       DO k=1,nzsendp(ipatch,isend,1),1
+#else
+                 DO k=1,nzsendp(ipatch,isend,1),1
                     DO j=jstart, jend, 1
                        DO i=istart, iend, 1
@@ -3775 +3816 @@
           ENDIF
 
-          IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
+          !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
 
        ELSE
@@ -3785 +3826 @@
     ENDDO ! Loop over sends
 
-!    CALL timing_stop('mpi_sends')
+    ! CALL timing_stop('mpi_sends')
 
 #if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
@@ -3793 +3834 @@
     ! Wait on the receives that were posted earlier
 
-!    CALL timing_start('mpi_recvs')
+    ! CALL timing_start('mpi_recvs')
 
     ! Copy just the set of flags we're interested in for passing 
@@ -3814 +3855 @@
           WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1
        END IF
-       CALL ctl_stop('STOP')
+       CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error')
     END IF
 
@@ -3821 +3862 @@
           IF ( PRESENT(b2) ) THEN
 
-!             CALL timing_start('2dr_unpack')
+             ! CALL timing_start('2dr_unpack')
 
              ! Copy received data back into array
@@ -3839 +3880 @@
              END DO unpack_patches2r
 
-!             CALL timing_stop('2dr_unpack')
+             ! CALL timing_stop('2dr_unpack')
 
           ELSE IF ( PRESENT(ib2) ) THEN
@@ -3861 +3902 @@
            ELSE IF (PRESENT(b3) ) THEN
 
-!             CALL timing_start('3dr_unpack')
+              ! CALL timing_start('3dr_unpack')
              ic = 0
              unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch)
@@ -3872 +3913 @@
                 DO j=jstart, jend, 1
                    DO i=istart, iend, 1
-                      DO k=1,kdim1,1
-#else
-                DO k=1,kdim1,1
+                      DO k=1,nzrecvp(ipatch,irecv,1),1
+#else
+                DO k=1,nzrecvp(ipatch,irecv,1),1
                    DO j=jstart, jend, 1
                       DO i=istart, iend, 1
@@ -3881 +3922 @@
                          b3(i,j,k) = recvBuff(ic,irecv)
                       END DO
+#if defined key_z_first
+                      ! ARPDBG - wipe anything below the ocean bottom
+                      DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
+                         b3(i,j,k) = 0.0_wp
+                      END DO
+#endif
                    END DO
                 END DO
+
+                ! ARPDBG - wipe anything below the ocean bottom
+#if ! defined key_z_first
+                DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
+                   DO j=jstart, jend, 1
+                      DO i=istart, iend, 1
+                         b3(i,j,k) = 0.0_wp
+                      END DO
+                   END DO
+                END DO
+#endif 
+
              END DO unpack_patches3r
 
@@ -3899 +3958 @@
                 DO j=jstart, jend, 1
                    DO i=istart, iend, 1
-                      DO k=1,kdim1,1
-#else
-                DO k=1,kdim1,1
+                      DO k=1,nzrecvp(ipatch,irecv,1),1
+#else
+                DO k=1,nzrecvp(ipatch,irecv,1),1
                    DO j=jstart, jend, 1
                       DO i=istart, iend, 1
@@ -3915 +3974 @@
 
        CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
-       IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
+       !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
 
     END DO ! while irecv != MPI_UNDEFINED
 
-!    CALL timing_stop('mpi_recvs')
+    ! CALL timing_stop('mpi_recvs')
 
     ! All receives done and unpacked so can deallocate the associated
     ! buffers
-    IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)
-    IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
+    !IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)
+    !IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
 
 #if defined DEBUG_COMMS
@@ -3940 +3999 @@
     !          loop!
     IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
+
+       ! Find out the sizes of the arrays.
+       kdim1 = 1
+       IF ( PRESENT(b3) ) THEN
+          kdim1 = SIZE(b3,dim=index_z)
+       ELSEIF ( PRESENT(ib3) ) THEN
+          kdim1 = SIZE(ib3,dim=index_z)
+       ENDIF
+
 
        IF ( enabled(Iplus) ) THEN
@@ -3996 +4064 @@
        ENDIF
 
-    ENDIF
+    ENDIF ! cyclic_bc .AND. jpni == 1
 
     ! Copy just the set of flags we're interested in for passing to  
@@ -4009 +4077 @@
     IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff)
 
-!    CALL timing_stop('exchs_generic')
+    ! CALL timing_stop('exchs_generic')
     !CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat)
 
@@ -4313 +4381 @@
     CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat)
 
+#if defined key_mpp_mpi
+
     ! If we get into this routine it's because : North fold condition and mpp 
     ! with more than one PE across i : we deal only with the North condition
 
     ! Set no. of rows from a module parameter that is also used in exchtestmod
+    ! and mpp_ini_north
     ijpj = num_nfold_rows
 
@@ -5244 +5315 @@
     CALL prof_region_end(NORTHLISTSCATTER, iprofStat)
 
+#endif /* key_mpp_mpi */
+
     CALL prof_region_end(ARPNORTHLISTCOMMS, iprofStat)
 
@@ -5255 +5328 @@
     !!
     !! ** Purpose :
-    !!      Ensure proper north fold horizontal bondary condition in mpp configuration
-    !!      in case of jpn1 > 1 (for 2d array )
+    !!      Ensure proper north fold horizontal bondary condition in mpp 
+    !!      configuration in case of jpn1 > 1 (for 2d array )
     !!
     !! ** Method :
@@ -5266 +5339 @@
     !!   8.5  !  03-09  (J.M. Molines ) For mpp folding condition at north
     !!                                  from lbc routine
-    !!   9.0  !  03-12  (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
+    !!   9.0  !  03-12  (J.M. Molines ) encapsulation into lib_mpp, coding 
+    !!                                  rules of lbc_lnk
     !!----------------------------------------------------------------------
     USE par_oce,     ONLY : jpni, jpi, jpj
@@ -5273 +5347 @@
     USE mapcomm_mod, ONLY : pielb, piesub
     USE lib_mpp,     ONLY : ctl_stop
+    USE arpdebugging, ONLY: dump_array
     IMPLICIT none
     !! * Arguments
@@ -5287 +5362 @@
     !! * Local declarations
 
-    INTEGER, PARAMETER :: ijpj = 4
+    INTEGER :: ijpj
     INTEGER :: ji, jj,  jr, jproc
     INTEGER :: ierr
@@ -5303 +5378 @@
     ! with more than one PE across i : we deal only with the North condition
 
+    ! Set local from public PARAMETER
+    ijpj = num_nfold_rows
+
     CALL prof_region_begin(ARPNORTHCOMMS2D, "North2D", iprofStat)
 
+#if defined key_mpp_mpi
+
     IF(.not. ALLOCATED(ztab2))THEN
 
-       ALLOCATE(ztab2(jpiglo,4),                &
-                znorthgloio2(nwidthmax,4,jpni), &
-                znorthloc2(nwidthmax,4),        &
+       ALLOCATE(ztab2(jpiglo,ijpj),                &
+                znorthgloio2(nwidthmax,ijpj,ndim_rank_north), &
+                znorthloc2(nwidthmax,ijpj),        &
                 STAT=ierr)
        IF(ierr .ne. 0)THEN
@@ -5321 +5401 @@
     ijpjm1=ijpj-1
 
-    ! put the last 4 jlines of pt2d into znorthloc2
+    ! put the last ijpj jlines of pt2d into znorthloc2
     znorthloc2(:,:) = 0_wp ! because of padding for nwidthmax
-    DO ij = 1, ijpj, 1
+
+    ! jeub is the upper j limit of current domain in global coords
+    !
+    !                      |======================= jpjglo     ^ 
+    !    <Trimmed>         |                                  /|\
+    !                      |----------------------- jpjglo-1   |
+    !                      |                                   |
+    ! |---------jeub--------------------------------           
+    ! |                    |                                   j
+    ! |--------------------------------------------            
+    ! |                    |                                   |
+    ! |--------------------------------------------            |
+    !
+    ! No. of trimmed rows = jpjglo - jeub
+    ! No. of valid rows for n-fold = ijpj - <no. trimmed rows>
+    !                              = ijpj - jpjglo + jeub
+    ! Need an iterator that ends with max value ijpj and has (ijpj-jpjglo+jeub)
+    ! distinct values so start point must be:
+    !  ij_start = ijpj - (ijpj-jpjglo+jeub) + 1 = jpjglo - jeub + 1
+    ! => if jeub == jpjglo then we recover a starting value of 1.
+    !    if jeub == jpjglo - 10 then ij_start = 11 so no loop iterations
+    !    will be performed.
+
+#if defined NO_NFOLD_GATHER
+    ! Post receives for other PE's north-fold data
+    DO iproc = 1, ndim_rank_north, 1
+
+       IF( iproc-1 ==  nrank_north(iproc) ) CYCLE ! Skip this PE
+
+       CALL MPI_IRecv(znorthgloio2(), north_pts(iproc), MPI_DOUBLE_PRECISION, &
+                      nrank_north(iproc), iproc, tag, ncomm_north,            &
+                      nexch_flag(iproc) )
+    END DO
+#endif
+
+    DO ij = jpjglo - jeub + 1, ijpj, 1
+
        jj = nlcj - ijpj + ij
        znorthloc2(nldi:nlei,ij)=pt2d(nldi:nlei,jj)
     END DO
+
+!    CALL dump_array(0,'znorthloc2',znorthloc2,withHalos=.TRUE.,toGlobal=.FALSE.)
 
     IF (npolj /= 0 ) THEN
@@ -5335 +5453 @@
                        znorthgloio2,itaille,MPI_DOUBLE_PRECISION,  &
                        0, ncomm_north, ierr)
+
     ENDIF
 
     IF (narea == north_root+1 ) THEN
        ! recover the global north array
+       ! ztab2 has full width of global domain
        ztab2(:,:) = 0_wp
 
@@ -5350 +5470 @@
        END DO
 
+!       CALL dump_array(0,'ztab2',ztab2,withHalos=.TRUE.,toGlobal=.FALSE.)
 
        ! 2. North-Fold boundary conditions
@@ -5495 +5616 @@
       ENDIF
 
-      ! put in the last ijpj jlines of pt2d znorthloc2
-      DO ij = 1, ijpj, 1
+      ! Put the last ijpj jlines of pt2d into znorthloc2 while allowing
+      ! for any trimming of domain (see earlier comments and diagram)
+      DO ij = jpjglo - jeub + 1, ijpj, 1
          jj = nlcj - ijpj + ij
          pt2d(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
       END DO
+
+#endif /* key_mpp_mpi */
 
       CALL prof_region_end(ARPNORTHCOMMS2D, iprofStat)
@@ -5512 +5636 @@
     !!
     !! ** Purpose :
-    !!      Ensure proper north fold horizontal bondary condition in mpp configuration
-    !!      in case of jpn1 > 1 (for 2d array )
+    !!      Ensure proper north fold horizontal bondary condition in mpp 
+    !!      configuration in case of jpn1 > 1 (for 2d array )
     !!
     !! ** Method :
@@ -5545 +5669 @@
     !! * Local declarations
 
-    INTEGER, PARAMETER :: ijpj = 4
+    INTEGER :: ijpj
     INTEGER :: ji, jj,  jr, jproc
     INTEGER :: ierr
@@ -5561 +5685 @@
     ! with more than one PE across i : we deal only with the North condition
 
+#if defined key_mpp_mpi
+
+    ijpj = num_nfold_rows
+    ijpjm1=ijpj - 1
+
+
      IF(.not. ALLOCATED(ztab2))THEN
 
-        ALLOCATE(ztab2(jpiglo,4),                &
-                 znorthgloio2(nwidthmax,4,jpni), &
-                 znorthloc2(nwidthmax,4),        &
+        ALLOCATE(ztab2(jpiglo,ijpj),                &
+                 znorthgloio2(nwidthmax,ijpj,jpni), &
+                 znorthloc2(nwidthmax,ijpj),        &
                  STAT=ierr)
         IF(ierr .ne. 0)THEN
@@ -5575 +5705 @@
     ! ---------------
 
-    ijpjm1=ijpj - 1
-
-    ! put in znorthloc2 the last 4 jlines of ib2
+    ! Put the last ijpj jlines of ib2 into znorthloc2 while allowing
+    ! for any trimming of domain (see earlier comments and diagram in
+    ! mpp_lbc_north_2d).
     znorthloc2(:,:) = 0  ! because of padding for nwidthmax
-    DO ij = 1, ijpj, 1
+    DO ij = jpjglo - jeub + 1, ijpj, 1
        jj = nlcj - ijpj + ij
        znorthloc2(nldi:nlei,ij)=ib2(nldi:nlei,jj)
@@ -5602 +5732 @@
           ilei=nleit (jproc)
           iilb=pielb(jproc)
-          WRITE (*,*)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',ildi, ilei, iilb, ijpj
+          !WRITE (*,*)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',&
+          !            ildi, ilei, iilb, ijpj
           ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) = &
                                      znorthgloio2(ildi:ilei,1:ijpj,jr)
@@ -5740 +5871 @@
             ilei=nleit (jproc)
             iilb=pielb(jproc)
-            znorthgloio2(ildi:ilei,1:ijpj,jr)=ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
+            znorthgloio2(ildi:ilei,1:ijpj,jr) = &
+                                ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
          END DO
 
@@ -5752 +5884 @@
       ENDIF
 
-      ! put in the last ijpj jlines of ib2 znorthloc2
-      DO ij = 1, ijpj, 1
+      ! put in the last ijpj jlines of ib2 from znorthloc2 while allowing
+      ! for any trimming of domain (see earlier comments and diagram in
+      ! mpp_lbc_north_2d).
+      DO ij = jpjglo - jeub + 1, ijpj, 1
          jj = nlcj - ijpj + ij
          ib2(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
       END DO
       WRITE(*,*) 'ARPDBG: finished in mpp_lbc_north_i2d'
+
+#endif /* key_mpp_mpi */
+
    END SUBROUTINE mpp_lbc_north_i2d
 
@@ -5797 +5934 @@
 
      !! * Local declarations
-     INTEGER, PARAMETER :: ijpj = 4
+     INTEGER :: ijpj
      INTEGER :: ji, jj, jk, jr, jproc
      INTEGER :: ierr
@@ -5814 +5951 @@
      ! mpp with more than one proc across i : we deal only with the North 
      ! condition
+#if defined key_mpp_mpi
+
+     ijpj = num_nfold_rows
+     ijpjm1=ijpj - 1
 
      IF(.not. ALLOCATED(ztab))THEN
 
-        ALLOCATE(ztab(jpiglo,4,jpk),                &
-                 znorthgloio(nwidthmax,4,jpk,jpni), &
-                 znorthloc(nwidthmax,4,jpk),        &
+        ALLOCATE(ztab(jpiglo,ijpj,jpk),                &
+                 znorthgloio(nwidthmax,ijpj,jpk,jpni), &
+                 znorthloc(nwidthmax,ijpj,jpk),        &
                  STAT=ierr)
         IF(ierr .ne. 0)THEN
@@ -5835 +5976 @@
      ! ---------------
 
-    ijpjm1=ijpj - 1
-
-    ! Put the last ijpj jlines of pt3d into znorthloc
-    !ARPDBG znorthloc(:,:,:) = 999_wp ! because of padding for nwidthmax - 999 is
-                              ! for debugging
-#if defined key_z_first
-    DO ij = 1, ijpj, 1
+    ! Put the last ijpj jlines of pt3d into znorthloc while allowing
+    ! for any trimming of domain (see earlier comments and diagram in
+    ! mpp_lbc_north_2d).
+    ! Have to initialise all to zero in case chunks are missing due to domain
+    ! trimming
+    znorthloc(:,:,:) = 0.0_wp
+#if defined key_z_first
+    DO ij = jpjglo - jeub + 1, ijpj, 1
        jj = nlcj - ijpj + ij
        DO jk = 1, jpk 
 #else
     DO jk = 1, jpk 
-       DO ij = 1, ijpj, 1
+       DO ij = jpjglo - jeub + 1, ijpj, 1
           jj = nlcj - ijpj + ij
 #endif
@@ -5856 +5998 @@
     IF (npolj /= 0 ) THEN
        ! Build in proc 0 of ncomm_north the znorthgloio
-       !ARPDBG znorthgloio(:,:,:,:) = 0_wp
 
 #ifdef key_mpp_shmem
@@ -5875 +6016 @@
     IF (narea == north_root+1 ) THEN
        ! recover the global north array
-       !ARPDBG ztab(:,:,:) = 0_wp
+       ztab(:,:,:) = 0_wp
 
        DO jr = 1, ndim_rank_north
@@ -5890 +6031 @@
        ! ===============
 #if defined key_z_first
-
 
        ! 2. North-Fold boundary conditions
@@ -6179 +6319 @@
 #endif
 
-    ! put in the last ijpj jlines of pt3d znorthloc
-#if defined key_z_first
-    DO ij = 1, ijpj, 1
+    ! put in the last ijpj jlines of pt3d znorthloc while allowing
+    ! for any trimming of domain (see earlier comments and diagram in
+    ! mpp_lbc_north_2d).
+#if defined key_z_first
+    DO ij = jpjglo - jeub + 1, ijpj, 1
        jj = nlcj - ijpj + ij
        DO jk = 1 , jpk 
 #else
     DO jk = 1 , jpk 
-       DO ij = 1, ijpj, 1
+       DO ij = jpjglo - jeub + 1, ijpj, 1
           jj = nlcj - ijpj + ij
 #endif
@@ -6194 +6336 @@
 
     CALL prof_region_end(NORTH3DSCATTER, iprofStat)
+
+#endif /* key_mpp_mpi */
 
   END SUBROUTINE mpp_lbc_north_3d
@@ -6235 +6379 @@
 
      !! * Local declarations
-     INTEGER, PARAMETER :: ijpj = 4
-     INTEGER, PARAMETER :: ijpjm1 = ijpj - 1
+     INTEGER :: ijpj
+     INTEGER :: ijpjm1
      INTEGER :: ii, ji, jj, jk, jr, jproc
      INTEGER :: ierr
@@ -6254 +6398 @@
      ! mpp with more than one proc across i : we deal only with the North 
      ! condition
+
+     ijpj = num_nfold_rows
+     ijpjm1 = ijpj - 1
 
      IF(.not. ALLOCATED(ztab))THEN
@@ -6269 +6416 @@
      ! ---------------
 
-    ! put in znorthloc the last ijpj jlines of pt3d
-    znorthloc(:,:,:) = 0 ! because of padding for nwidthmax
-#if defined key_z_first
-    DO ij = 1, ijpj, 1
+    ! put in znorthloc the last ijpj jlines of pt3d while allowing
+    ! for any trimming of domain (see earlier comments and diagram in
+    ! mpp_lbc_north_2d).
+    znorthloc(:,:,:) = 0 ! because of padding for nwidthmax and domain
+                         ! trimming
+#if defined key_z_first
+    DO ij = jpjglo - jeub + 1, ijpj, 1
        jj = nlcj - ijpj + ij
        DO jk = 1, jpk 
 #else
     DO jk = 1, jpk 
-       DO ij = 1, ijpj, 1
+       DO ij = jpjglo - jeub + 1, ijpj, 1
           jj = nlcj - ijpj + ij
 #endif
@@ -6608 +6758 @@
 #endif
 
-    ! put in the last ijpj jlines of pt3d znorthloc
-#if defined key_z_first
-    DO ij = 1, ijpj, 1
+    ! put in the last ijpj jlines of pt3d znorthloc while allowing
+    ! for any trimming of domain (see earlier comments and diagram in
+    ! mpp_lbc_north_2d).
+#if defined key_z_first
+    DO ij = jpjglo - jeub + 1, ijpj, 1
        jj = nlcj - ijpj + ij
        DO ii = nldi, nlei, 1
@@ -6616 +6768 @@
 #else
     DO jk = 1 , jpk 
-       DO ij = 1, ijpj, 1
+       DO ij = jpjglo - jeub + 1, ijpj, 1
           jj = nlcj - ijpj + ij
           DO ii = nldi, nlei, 1