Index: /branches/DEV_1879_mpp_sca/NEMO/OPA_SRC/lib_mpp.F90
===================================================================
--- /branches/DEV_1879_mpp_sca/NEMO/OPA_SRC/lib_mpp.F90	(revision 1925)
+++ /branches/DEV_1879_mpp_sca/NEMO/OPA_SRC/lib_mpp.F90	(revision 1926)
@@ -159,4 +159,11 @@
    REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ::   tr2ns, tr2sn  ! 2d for north-south & south-north + extra outer halo
    REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ::   tr2ew, tr2we  ! 2d for east-west   & west-east   + extra outer halo
+
+   ! North fold arrays used to minimise the use of allgather operations. Set in opa_northcomms so need to be public
+   INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 8                                 ! Assumed maximum number of active neighbours
+   INTEGER, PUBLIC,  DIMENSION (jpmaxngh,4)        ::   isendto
+   INTEGER, PUBLIC,  DIMENSION (4)                 ::   nsndto
+   LOGICAL, PUBLIC                                 ::   lnorth_nogather = .FALSE.
+   INTEGER, PUBLIC                                 ::   ityp
    !!----------------------------------------------------------------------
    !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009) 
@@ -354,16 +361,16 @@
       CASE ( -1 )
          CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
-         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
+         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
       CASE ( 0 )
          CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
          CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
-         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
-         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
+         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
+         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
       CASE ( 1 )
          CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
-         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
+         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
       END SELECT
@@ -407,16 +414,16 @@
       CASE ( -1 )
          CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
-         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
+         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
       CASE ( 0 )
          CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
          CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
-         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
-         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
+         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
+         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
       CASE ( 1 ) 
          CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
-         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
+         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
       END SELECT
@@ -548,16 +555,16 @@
       CASE ( -1 )
          CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
-         CALL mpprecv( 1, t2ew(1,1,2), imigr )
+         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
       CASE ( 0 )
          CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
          CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
-         CALL mpprecv( 1, t2ew(1,1,2), imigr )
-         CALL mpprecv( 2, t2we(1,1,2), imigr )
+         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
+         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
       CASE ( 1 )
          CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
-         CALL mpprecv( 2, t2we(1,1,2), imigr )
+         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
       END SELECT
@@ -601,16 +608,16 @@
       CASE ( -1 )
          CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
-         CALL mpprecv( 3, t2ns(1,1,2), imigr )
+         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
       CASE ( 0 )
          CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
          CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
-         CALL mpprecv( 3, t2ns(1,1,2), imigr )
-         CALL mpprecv( 4, t2sn(1,1,2), imigr )
+         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
+         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
       CASE ( 1 )
          CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
-         CALL mpprecv( 4, t2sn(1,1,2), imigr )
+         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
       END SELECT
@@ -729,16 +736,16 @@
       CASE ( -1 )
          CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
-         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
+         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
       CASE ( 0 )
          CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
          CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
-         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
-         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
+         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea )
+         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
       CASE ( 1 )
          CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
-         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
+         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
       END SELECT
@@ -788,16 +795,16 @@
       CASE ( -1 )
          CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
-         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
+         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
       CASE ( 0 )
          CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
          CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
-         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
-         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
+         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono )
+         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
          IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
       CASE ( 1 ) 
          CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
-         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
+         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso )
          IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
       END SELECT
@@ -932,16 +939,16 @@
       CASE ( -1 )
          CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
-         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
+         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
       CASE ( 0 )
          CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
          CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
-         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
-         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
+         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea )
+         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
       CASE ( 1 )
          CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
-         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
+         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
       END SELECT
@@ -985,16 +992,16 @@
       CASE ( -1 )
          CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
-         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
+         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
       CASE ( 0 )
          CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
          CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
-         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
-         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
+         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono )
+         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
       CASE ( 1 )
          CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
-         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
+         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso )
          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
       END SELECT
@@ -1051,5 +1058,5 @@
 
 
-   SUBROUTINE mpprecv( ktyp, pmess, kbytes )
+   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
       !!----------------------------------------------------------------------
       !!                  ***  routine mpprecv  ***
@@ -1061,10 +1068,20 @@
       INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
       INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
+      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number 
       !!
       INTEGER :: istatus(mpi_status_size)
       INTEGER :: iflag
-      !!----------------------------------------------------------------------
-      !
-      CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag )
+      INTEGER :: use_source
+      !!----------------------------------------------------------------------
+      !
+
+      ! If a specific process number has been passed to the receive call, 
+      ! use that one. Default is to use mpi_any_source
+      use_source=mpi_any_source
+      if(present(ksource)) then
+         use_source=ksource
+      end if
+
+      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag )
       !
    END SUBROUTINE mpprecv
@@ -1681,16 +1698,16 @@
          IF( nbondi == -1 ) THEN
             CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
-            CALL mpprecv( 1, t2ew(1,1,2), imigr )
+            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
             IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
          ELSEIF( nbondi == 0 ) THEN
             CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
             CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
-            CALL mpprecv( 1, t2ew(1,1,2), imigr )
-            CALL mpprecv( 2, t2we(1,1,2), imigr )
+            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
+            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
             IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
             IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err )
          ELSEIF( nbondi == 1 ) THEN
             CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
-            CALL mpprecv( 2, t2we(1,1,2), imigr )
+            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
             IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
          ENDIF
@@ -1727,16 +1744,16 @@
          IF( nbondj == -1 ) THEN
             CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
-            CALL mpprecv( 3, t2ns(1,1,2), imigr )
+            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
             IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
          ELSEIF( nbondj == 0 ) THEN
             CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
             CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
-            CALL mpprecv( 3, t2ns(1,1,2), imigr )
-            CALL mpprecv( 4, t2sn(1,1,2), imigr )
+            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
+            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
             IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
             IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err )
          ELSEIF( nbondj == 1 ) THEN
             CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
-            CALL mpprecv( 4, t2sn(1,1,2), imigr)
+            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso)
             IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
          ENDIF
@@ -2045,7 +2062,12 @@
       REAL(wp), DIMENSION(jpi   ,4,jpk)      ::   znorthloc
       REAL(wp), DIMENSION(jpi   ,4,jpk,jpni) ::   znorthgloio
+      REAL(wp), DIMENSION(jpi,   4,jpk)      ::   zfoldwrk           ! Workspace for message transfers avoiding mpi_allgather
+      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req5            ! for mpi_isend when avoiding mpi_allgather
+      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
+      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
       !!----------------------------------------------------------------------
       !   
       ijpj   = 4
+      ityp = -1
       ijpjm1 = 3
       ztab(:,:,:) = 0.e0
@@ -2058,19 +2080,85 @@
       !                                     ! Build in procs of ncomm_north the znorthgloio
       itaille = jpi * jpk * ijpj
-      CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
-         &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
+      IF ( lnorth_nogather ) THEN
+!
+! Avoid the use of mpi_allgather by exchanging only with the processes already identified (in opa_northcomms)
+! as being  involved in this process' northern boundary exchange
+!
+! First put local values into the global arraay
+         DO jj = nlcj-ijpj+1, nlcj
+           ij = jj - nlcj + ijpj
+           DO ji = 1, nlci
+             ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:)
+           END DO
+         END DO
+
+!
+! Set the exchange type in order to access the correct list of active neighbours
+!
+         SELECT CASE ( cd_type )
+            CASE ( 'T' , 'W' )
+             ityp = 1
+            CASE ( 'U' )
+             ityp = 2
+            CASE ( 'V' )
+             ityp = 3
+            CASE ( 'F' )
+             ityp = 4
+            CASE DEFAULT
+!
+! Set a default value for unsupported types which will cause a fallback to
+! the mpi_allgather method
+!
+             ityp = -1
+          END SELECT
+          IF ( ityp .gt. 0 ) THEN
+
+           DO jr = 1,nsndto(ityp)
+            CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req5(jr) )
+           END DO
+           DO jr = 1,nsndto(ityp)
+            CALL mpprecv(5, zfoldwrk, itaille, isendto(jr,ityp))
+            iproc = isendto(jr,ityp) + 1
+            ildi=nldit (iproc)
+            ilei=nleit (iproc)
+            iilb=nimppt(iproc)
+            DO jj = 1, 4
+               DO ji = ildi, ilei
+                  ztab(ji+iilb-1,jj,:) = zfoldwrk(ji,jj,:)
+               END DO
+            END DO
+           END DO
+           IF(l_isend) THEN
+              DO jr = 1,nsndto(ityp)
+                CALL mpi_wait(ml_req5(jr), ml_stat, ml_err)
+              END DO
+           ENDIF
+
+          ENDIF
+
+      ENDIF
+
+      IF ( ityp .lt. 0 ) THEN
+         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
+            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
       !
       !                                     ! recover the global north array
-      DO jr = 1, ndim_rank_north
-         iproc = nrank_north(jr) + 1
-         ildi  = nldit (iproc)
-         ilei  = nleit (iproc)
-         iilb  = nimppt(iproc)
-         DO jj = 1, 4
-            DO ji = ildi, ilei
-               ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
+         DO jr = 1, ndim_rank_north
+            iproc = nrank_north(jr) + 1
+            ildi  = nldit (iproc)
+            ilei  = nleit (iproc)
+            iilb  = nimppt(iproc)
+            DO jj = 1, 4
+               DO ji = ildi, ilei
+                  ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
+               END DO
             END DO
          END DO
-      END DO
+      ENDIF
+      !
+! The ztab array has been either:
+!  a. Fully populated by the mpi_allgather operation or
+!  b. Had the active points for this domain and northern neighbours populated by peer to peer exchanges
+! Either way the array may be folded by lbc_nfd and the result for the span of this domain will be identical.
       !
       CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
@@ -2111,7 +2199,12 @@
       REAL(wp), DIMENSION(jpi   ,4)      ::   znorthloc
       REAL(wp), DIMENSION(jpi   ,4,jpni) ::   znorthgloio
+      REAL(wp), DIMENSION(jpi,   4)      ::   zfoldwrk           ! Workspace for message transfers avoiding mpi_allgather
+      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req5            ! for mpi_isend when avoiding mpi_allgather
+      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
+      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
       !!----------------------------------------------------------------------
       !
       ijpj   = 4
+      ityp = -1
       ijpjm1 = 3
       ztab(:,:) = 0.e0
@@ -2124,28 +2217,96 @@
       !                                     ! Build in procs of ncomm_north the znorthgloio
       itaille = jpi * ijpj
-      CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
-         &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
-      !
-      DO jr = 1, ndim_rank_north            ! recover the global north array
-         iproc = nrank_north(jr) + 1
-         ildi=nldit (iproc)
-         ilei=nleit (iproc)
-         iilb=nimppt(iproc)
-         DO jj = 1, 4
-            DO ji = ildi, ilei
-               ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
+      IF ( lnorth_nogather ) THEN
+!
+! Avoid the use of mpi_allgather by exchanging only with the processes already identified (in opa_northcomms) 
+! as being  involved in this process' northern boundary exchange
+!
+! First put local values into the global array
+!
+         DO jj = nlcj-ijpj+1, nlcj
+           ij = jj - nlcj + ijpj
+           DO ji = 1, nlci
+             ztab(ji+nimpp-1,ij) = pt2d(ji,jj)
+           END DO
+         END DO
+
+!
+! Set the exchange type in order to access the correct list of active neighbours
+!
+         SELECT CASE ( cd_type )
+            CASE ( 'T' , 'W' )
+             ityp = 1
+            CASE ( 'U' )
+             ityp = 2
+            CASE ( 'V' )
+             ityp = 3
+            CASE ( 'F' )
+             ityp = 4
+            CASE DEFAULT
+!
+! Set a default value for unsupported types which will cause a fallback to
+! the mpi_allgather method
+!
+             ityp = -1
+          END SELECT
+
+          IF ( ityp .gt. 0 ) THEN
+
+           DO jr = 1,nsndto(ityp)
+            CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req5(jr) )
+           END DO
+           DO jr = 1,nsndto(ityp)
+            CALL mpprecv(5, zfoldwrk, itaille, isendto(jr,ityp))
+            iproc = isendto(jr,ityp) + 1
+            ildi=nldit (iproc)
+            ilei=nleit (iproc)
+            iilb=nimppt(iproc)
+            DO jj = 1, 4
+               DO ji = ildi, ilei
+                  ztab(ji+iilb-1,jj) = zfoldwrk(ji,jj)
+               END DO
             END DO
-         END DO
-      END DO
-      !
-      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
-      !
-      !
-      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
-         ij = jj - nlcj + ijpj
-         DO ji = 1, nlci
-            pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
-         END DO
-      END DO
+           END DO
+           IF(l_isend) THEN
+              DO jr = 1,nsndto(ityp)
+                CALL mpi_wait(ml_req5(jr), ml_stat, ml_err)
+              END DO
+           ENDIF
+
+          ENDIF
+
+      ENDIF
+
+      IF ( ityp .lt. 0 ) THEN
+       CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
+          &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
+      !
+       DO jr = 1, ndim_rank_north            ! recover the global north array
+          iproc = nrank_north(jr) + 1
+          ildi=nldit (iproc)
+          ilei=nleit (iproc)
+          iilb=nimppt(iproc)
+          DO jj = 1, 4
+             DO ji = ildi, ilei
+                ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
+             END DO
+          END DO
+       END DO
+      ENDIF
+      !
+! The ztab array has been either:
+!  a. Fully populated by the mpi_allgather operation or
+!  b. Had the active points for this domain and northern neighbours populated by peer to peer exchanges
+! Either way the array may be folded by lbc_nfd and the result for the span of this domain will be identical.
+      !
+       CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
+      !
+      !
+       DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
+          ij = jj - nlcj + ijpj
+          DO ji = 1, nlci
+             pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
+          END DO
+       END DO
       !
    END SUBROUTINE mpp_lbc_north_2d
Index: /branches/DEV_1879_mpp_sca/NEMO/OPA_SRC/opa.F90
===================================================================
--- /branches/DEV_1879_mpp_sca/NEMO/OPA_SRC/opa.F90	(revision 1925)
+++ /branches/DEV_1879_mpp_sca/NEMO/OPA_SRC/opa.F90	(revision 1926)
@@ -257,4 +257,6 @@
       ENDIF
 !!gm c1d end
+
+      CALL opa_northcomms                   ! Initialise the northfold neighbour lists (must be done after the masks are defined)
 
       IF( ln_ctl )   CALL prt_ctl_init      ! Print control
@@ -407,4 +409,146 @@
    END SUBROUTINE opa_closefile
 
+   SUBROUTINE opa_northcomms
+      !!======================================================================
+      !!                     ***  ROUTINE  opa_northcomms  ***
+      !! opa_northcomms    :  Setup for north fold exchanges with explicit peer to peer messaging
+      !!=====================================================================
+      !!----------------------------------------------------------------------
+      !! 
+      !! ** Purpose :   Initialization of the northern neighbours lists.
+      !!----------------------------------------------------------------------
+
+      INTEGER ::   ji, jj, jk, ij    ! dummy loop indices
+      INTEGER ::   ijpj              ! ???
+      INTEGER,  DIMENSION (jpi,4,4) ::   ifoldnbrs
+      REAL(wp), DIMENSION (jpi,jpj) ::   znnbrs     ! workspace
+      LOGICAL,  DIMENSION (jpnij)   ::   lrankset   ! workspace
+
+      IF(lwp) WRITE(numout,*)
+      IF(lwp) WRITE(numout,*) 'opa_northcomms : Initialization of the northern neighbours lists'
+      IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
+
+      !!----------------------------------------------------------------------
+      nsndto = 0
+      isendto = -1
+      ijpj   = 4
+      !
+! Exchange and store ranks on northern rows
+
+      lrankset = .FALSE.
+      znnbrs = narea * tmask(:,:,1)
+      CALL lbc_lnk( znnbrs, 'T', 1. )
+
+      IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN
+        do jj = nlcj-ijpj+1, nlcj
+         ij = jj - nlcj + ijpj
+         ifoldnbrs(:,ij,1) = int(znnbrs(:,jj))
+         do ji = 1,jpi
+          if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) &
+         &       lrankset(int(znnbrs(ji,jj))) = .true.
+         end do
+        end do
+
+        do jj = 1,jpnij
+         IF (lrankset(jj)) THEN
+          nsndto(1) = nsndto(1) + 1
+          IF(nsndto(1) .gt. jpmaxngh ) THEN
+           CALL ctl_stop( ' Too many neighbours in opa_northcomms ', &
+           &              ' jpmaxngh will need to be increased ')
+          ENDIF
+          isendto(nsndto(1),1) = jj-1   ! narea converted to MPI rank
+         ENDIF
+        end do
+      ENDIF
+      
+      lrankset = .FALSE.
+      znnbrs = narea * umask(:,:,1)
+      CALL lbc_lnk( znnbrs, 'U', 1. )
+
+      IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN
+        do jj = nlcj-ijpj+1, nlcj
+         ij = jj - nlcj + ijpj
+         ifoldnbrs(:,ij,2) = int(znnbrs(:,jj))
+         do ji = 1,jpi
+          if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) &
+         &       lrankset(int(znnbrs(ji,jj))) = .true.
+         end do
+        end do
+
+        do jj = 1,jpnij
+         IF (lrankset(jj)) THEN
+          nsndto(2) = nsndto(2) + 1
+          IF(nsndto(2) .gt. jpmaxngh ) THEN
+           CALL ctl_stop( ' Too many neighbours in opa_northcomms ', &
+           &              ' jpmaxngh will need to be increased ')
+          ENDIF
+          isendto(nsndto(2),2) = jj-1   ! narea converted to MPI rank
+         ENDIF
+        end do
+      ENDIF
+
+      lrankset = .FALSE.
+      znnbrs = narea * vmask(:,:,1)
+      CALL lbc_lnk( znnbrs, 'V', 1. )
+
+      IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN
+        do jj = nlcj-ijpj+1, nlcj
+         ij = jj - nlcj + ijpj
+         ifoldnbrs(:,ij,3) = int(znnbrs(:,jj))
+         do ji = 1,jpi
+          if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) &
+         &       lrankset(int(znnbrs(ji,jj))) = .true.
+         end do
+        end do
+
+        do jj = 1,jpnij
+         IF (lrankset(jj)) THEN
+          nsndto(3) = nsndto(3) + 1
+          IF(nsndto(3) .gt. jpmaxngh ) THEN
+           CALL ctl_stop( ' Too many neighbours in opa_northcomms ', &
+           &              ' jpmaxngh will need to be increased ')
+          ENDIF
+          isendto(nsndto(3),3) = jj-1   ! narea converted to MPI rank
+         ENDIF
+        end do
+      ENDIF
+
+      lrankset = .FALSE.
+      znnbrs = narea * fmask(:,:,1)
+!
+! filter top rows to counter any strong slip conditions
+!
+      do jj = nlcj-ijpj+1, nlcj
+      do ji = 1,jpi
+       znnbrs(ji,jj) = narea * MIN(1.0,fmask(ji,jj,1))
+      end do
+      enddo
+      CALL lbc_lnk( znnbrs, 'F', 1. )
+
+      IF ( njmppt(narea) .eq. MAXVAL( njmppt )) THEN
+        do jj = nlcj-ijpj+1, nlcj
+         ij = jj - nlcj + ijpj
+         ifoldnbrs(:,ij,4) = int(znnbrs(:,jj))
+         do ji = 1,jpi
+          if(int(znnbrs(ji,jj)) .ne. 0 .and. int(znnbrs(ji,jj)) .ne. narea ) &
+         &       lrankset(int(znnbrs(ji,jj))) = .true.
+         end do
+        end do
+
+        do jj = 1,jpnij
+         IF (lrankset(jj)) THEN
+          nsndto(4) = nsndto(4) + 1
+          IF(nsndto(4) .gt. jpmaxngh ) THEN
+           CALL ctl_stop( ' Too many neighbours in opa_northcomms ', &
+           &              ' jpmaxngh will need to be increased ')
+          ENDIF
+          isendto(nsndto(4),4) = jj-1   ! narea converted to MPI rank
+         ENDIF
+        end do
+
+        lnorth_nogather = .TRUE.
+      ENDIF
+
+   END SUBROUTINE opa_northcomms
    !!======================================================================
 END MODULE opa
