source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/exchmod.F90 @ 3837

Last change on this file since 3837 was 3837, checked in by trackstand2, 8 years ago

Merge of finiss

File size: 229.9 KB
Line 
1MODULE exchmod
2  USE par_oce, ONLY: wp, jpiglo, jpjglo, jpkdta, jpi, jpj, jpk
3#if defined key_mpp_mpi
4  USE mpi ! For better interface checking
5#endif
6#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
7  USE dom_oce,        ONLY: narea
8#endif
9  USE profile
10!  USE timing, ONLY: timing_start, timing_stop
11  ! Make some key parameters from mapcomm_mod available to all who
12  ! USE this module
13  USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE, &
14                         jeub
15  IMPLICIT none
16
17!!#define DEBUG_COMMS
18
19  PRIVATE
20
21  ! Module containing variables to support the automatic allocation
22  ! of tags and flags for the exchange and collective communications
23  ! routines.
24
25  ! indexs, indexr-  Array indexes for send and receive flags.
26  ! max_flags     -  The number of slots in the flag arrays
27  ! i.e. the maximum number of simultaneous communications
28  ! current_tag   -  The current (last assigned) tag value
29  ! This is shared between exchanges and global operations
30  ! to avoid conflicts by the use of the same tag value.
31  ! min_tag       -  The minimum or starting tag value.
32  ! max_tag       -  The maximum tag value. When tags reach this value
33  ! they start again from the minimum.
34  ! max_tag_used  -  Records the largest tag value actually used.
35  ! n_tag_cycles  -  Number of cycles round the range min_tag to max_tag.
36  ! first_mod     -  First time flag for use of this module.
37
38  ! Set of arrays for exchange operations.
39
40  ! exch_flags    -  Array of flag arrays for exchanges
41  ! exch_flags1d  -  Array of only the current MPI receive operations
42  ! exch_tag      -  The tag value associated with this exchange
43  ! exch_busy     -  Indicates whether a slot in the flag array is being used
44
45  INTEGER, PARAMETER :: indexs=1,indexr=2
46  INTEGER, PARAMETER :: max_flags=40
47  INTEGER, PARAMETER :: min_tag=0
48  INTEGER :: current_tag,max_tag_used,max_tag,n_tag_cycles=0
49  LOGICAL :: first_mod=.TRUE.
50
51  INTEGER, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: exch_flags
52  INTEGER, ALLOCATABLE, DIMENSION(:),     SAVE :: exch_tag, exch_flags1d
53  LOGICAL, ALLOCATABLE, DIMENSION(:),     SAVE :: exch_busy
54
55  ! variables used in case of north fold condition in mpp_mpi
56  ! with jpni > 1
57  INTEGER, SAVE ::  &       !
58       ngrp_world,  &       ! group ID for the world processors
59       ngrp_north,  &       ! group ID for the northern processors (to be fold)
60       ncomm_north, &       ! communicator made by the processors belonging to ngrp_north
61       ndim_rank_north   ! number of 'sea' processor in the northern line (can be /= jpni !)
62
63  INTEGER, SAVE :: north_root ! number (in the comm_opa) of proc 0 in the northern comm
64  INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north  ! dim. ndim_rank_north, number
65                                                           ! of the procs belonging to ncomm_north
66  LOGICAL, SAVE :: do_nfold ! Whether this PE contributes to N-fold exchange
67                            !  -  takes domain trimming into account.
68  INTEGER, PARAMETER :: num_nfold_rows = 4 ! No. of rows at the top of the
69                                           ! global domain to use in applying
70                                           ! the north-fold condition (no value
71                                           ! other than 4 currently tested)
72
73  INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nfold_npts ! How many points each
74                                                         ! northern proc contrib
75                                                         ! to nfold exchange
76
77!FTRANS r3dptr :I :I :z
78!FTRANS i3dptr :I :I :z
79  TYPE exch_item
80     INTEGER               :: halo_width
81     INTEGER, DIMENSION(4) :: dirn
82     INTEGER               :: isgn
83     CHARACTER(LEN=1)      :: grid
84     LOGICAL               :: lfill
85     INTEGER,  DIMENSION(:,:),   POINTER :: i2dptr
86     INTEGER,  DIMENSION(:,:,:), POINTER :: i3dptr
87     REAL(wp), DIMENSION(:,:),   POINTER :: r2dptr
88     REAL(wp), DIMENSION(:,:,:), POINTER :: r3dptr
89  END TYPE exch_item
90
91  TYPE (exch_item), ALLOCATABLE, SAVE :: exch_list(:)
92  INTEGER, SAVE :: nextFreeExchItem, maxExchItems
93
94  ! Buffer for doing halo-exchange.
95  ! For a 3D array, halos are 2D slabs but copied into these buffers
96  ! as 1D vectors. 2nd dimension refers to the direction of the
97  ! communication.
98  ! For a 2D array, halos are 1D vectors anyway.
99  REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: sendBuff,  recvBuff
100  INTEGER , DIMENSION(:,:), ALLOCATABLE, SAVE :: sendIBuff, recvIBuff
101
102  INTERFACE bound_exch
103    MODULE PROCEDURE bound_exch2, bound_exch2i, &
104                     bound_exch3, bound_exch3i
105  END INTERFACE bound_exch
106
107  INTERFACE apply_north_fold
108    MODULE PROCEDURE apply_north_fold2, apply_north_fold2i, &
109                     apply_north_fold3, apply_north_fold3i
110  END INTERFACE apply_north_fold
111
112  INTERFACE mpp_lbc_north
113     MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_i3d, &
114                      mpp_lbc_north_2d, mpp_lbc_north_i2d
115  END INTERFACE
116
117  PUBLIC get_exch_handle, free_exch_handle, bound_exch, &
118         exch_tag, exch_flags, indexs, indexr, &
119         nrank_north, north_root, ndim_rank_north, &
120         ngrp_north, ngrp_world, ncomm_north, &
121         num_nfold_rows, do_nfold, nfold_npts, &
122         exchmod_alloc, add_exch, bound_exch_list, &
123         Iminus, Iplus, Jminus, Jplus, NONE, &
124         lbc_exch3, lbc_exch2
125
126#if defined key_mpp_mpi
127  PUBLIC MPI_COMM_WORLD, MPI_Wtime
128#endif
129
130  ! MPI only
131!!$#if defined key_mpp_mpi
132!!$  INCLUDE "mpif.h"
133!!$#endif
134!!$#if defined ARPVAMPIR
135!!$# include "vampir_sym_defs.inc"
136!!$#endif
137
138CONTAINS
139
140  INTEGER FUNCTION exchmod_alloc()
141    USE mapcomm_mod, Only: MaxComm
142    IMPLICIT none
143    ! Locals
144    INTEGER :: ierr, ii
145    ! Since halos are broken up into wet-point-only patches we
146    ! allocate the send and receive buffers  on a per-PE basis once we
147    ! know the sizes of the patches (in exchs_generic).
148    maxExchItems = 20
149    ALLOCATE(exch_list(maxExchItems),           &
150             exch_flags(max_flags,MaxComm,2),   &
151             exch_flags1d(MaxComm),             &
152             exch_busy(max_flags),              &
153             exch_tag(max_flags),               &
154             STAT=ierr)
155
156    IF(ierr .eq. 0)THEN
157
158       DO ii=1,maxExchItems,1
159          NULLIFY(exch_list(ii)%r2dptr, exch_list(ii)%r3dptr, &
160                  exch_list(ii)%i2dptr, exch_list(ii)%i3dptr)
161       END DO
162
163       exch_busy   = .FALSE.
164    ELSE
165       maxExchItems = 0
166    END IF
167
168    nextFreeExchItem = 1
169
170    ! Pass back the allocation status flag
171    exchmod_alloc = ierr
172
173  END FUNCTION exchmod_alloc
174
175
176  INTEGER FUNCTION get_exch_handle ( )
177    ! ---------------------------------------------------------------
178    ! Gets a new exchange handle
179    ! ---------------------------------------------------------------
180!!$#if defined DEBUG || defined DEBUG_COMMS
181!!$    USE in_out_manager, ONLY: numout, lwp
182!!$    USE dom_oce,        ONLY: narea
183!!$#endif
184    USE mapcomm_mod,    ONLY: MaxCommDir
185    IMPLICIT NONE
186
187    ! Local variables.
188
189    INTEGER :: h,ierr
190    LOGICAL :: got
191
192    IF ( first_mod ) THEN
193
194       ! First time in the module (i.e. exch or glob) set up the tags.
195
196       ! Set the maximum tag value.
197
198       got = .FALSE.
199#if defined key_mpp_mpi
200       CALL MPI_attr_get(MPI_comm_world,MPI_tag_ub,max_tag,got,ierr)
201       IF ( ierr.NE.0 ) CALL abort ()
202#endif /* key_mpp_mpi */
203       IF ( .NOT.got ) THEN
204
205          ! If no value was returned use the minimum possible tag max.
206          ! (p. 28 of Version 2.1 of the MPI standard or p. 19 of V.1 of the standard.)
207          max_tag = 32767
208       ENDIF
209#ifdef DEBUG
210       IF ( lwp ) WRITE (numout,*) 'MAX_TAG: set to ',max_tag
211#endif
212
213       ! Set the current tag to the minimum.
214
215       current_tag = min_tag
216       max_tag_used = current_tag
217
218       first_mod = .FALSE.
219    ENDIF
220
221    ! Look for a free location in the flags array.
222
223    flag_search : DO h=1,max_flags
224       IF ( .NOT.exch_busy(h) ) EXIT flag_search
225    ENDDO flag_search
226
227    IF ( h.GT.max_flags ) THEN
228
229       ! If no free flags array was found, flag an error.
230
231       STOP 'ERROR: get_exch_handle: no free flag array'
232    ELSE
233
234       ! Assign a new tag.
235
236       exch_busy(h) = .TRUE.
237
238       IF ( current_tag.GE.(max_tag-MaxCommDir) ) THEN
239
240          ! Wrap around.
241
242          current_tag = min_tag
243          n_tag_cycles = n_tag_cycles+1
244       ELSE
245          current_tag = current_tag + MaxCommDir
246       ENDIF
247       max_tag_used = MAX(max_tag_used,current_tag)
248       exch_tag(h) = current_tag
249
250!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
251!!$       IF ( lwp ) THEN
252!!$          WRITE (numout,'(1x,a,i6,a,i8,a,i3,a,i3,a)')  &
253!!$               'Process ',narea-1,' exch tag ',exch_tag(h) &
254!!$               ,' assigned flags ',h,' (',COUNT(exch_busy),' busy)'
255!!$          CALL flush (numout)
256!!$       ENDIF
257!!$#endif
258    ENDIF
259
260    get_exch_handle = h
261
262    RETURN
263
264  END FUNCTION get_exch_handle
265
266  ! ---------------------------------------------------------------
267
268  SUBROUTINE free_exch_handle ( h )
269    ! Frees exchange handle, h.
270!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
271!!$    USE in_out_manager, ONLY: numout, lwp
272!!$    USE dom_oce,        ONLY: narea
273!!$#endif
274    IMPLICIT NONE
275
276    ! Subroutine arguments.
277    INTEGER :: h ! Handle to be free'd
278
279    ! Free the flags array.
280   
281    IF ( h.GT.0 .AND. h.LE.max_flags ) THEN
282       exch_busy(h) = .FALSE.
283!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
284!!$       IF ( lwp ) THEN
285!!$          WRITE (numout,'(1x,a,i6,a,i8,a,i3)')                     'Process ',narea-1,' exch tag ',exch_tag(h)                   ,' freed    flags ',h
286!!$          CALL flush (numout)
287!!$       ENDIF
288!!$#endif
289    ELSE
290       WRITE (*,*) 'free_exch_handle: invalid handle ',h
291    ENDIF
292
293  END SUBROUTINE free_exch_handle
294
295  ! ------------------------------------------------------------------------
296
297  SUBROUTINE bound_exch_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
298                                  comm1, comm2, comm3, comm4,      &
299                                  cd_type, lfill, pval, isgn, lzero )
300    USE par_oce, ONLY: wp, jpreci, jprecj, jpim1
301    USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, &
302                       nperio, nbondi, npolj, narea
303    USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc
304    USE mapcomm_mod, ONLY: trimmed, eidx, widx
305    IMPLICIT none
306    INTEGER, INTENT(in)  :: nhalo,nhexch
307!FTRANS b3  :I :I :z
308!FTRANS ib3 :I :I :z
309    REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:)      :: b2
310    INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:)      :: ib2
311    REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:,:)    :: b3
312    INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:,:)    :: ib3
313    INTEGER,           INTENT(in) :: comm1, comm2, comm3, comm4
314    CHARACTER(len=1),  INTENT(in) :: cd_type
315    LOGICAL, OPTIONAL, INTENT(in) :: lfill
316    REAL(wp),OPTIONAL, INTENT(in) :: pval  ! background value (used at closed boundaries)
317    INTEGER, OPTIONAL, INTENT(in) :: isgn
318    LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to set halo values on closed boundaries
319    ! Local arguments
320    INTEGER :: itag          ! Communication handle
321    INTEGER :: isgnarg
322    INTEGER :: ii, jj, jk, ji    ! Loop indices
323    INTEGER :: ileft, iright ! First and last x-coord of internal points
324    INTEGER :: kdim1
325    INTEGER  :: iland ! Land values - zero by default unless pval passed in.
326    REAL(wp) :: zland !  "     "
327    LOGICAL :: lfillarg, lzeroarg
328    !!--------------------------------------------------------------------
329
330#if ! defined key_mpp_rkpart
331    RETURN
332#endif
333
334!    CALL prof_region_begin(ARPCOMMS, "IndivComms", iprofStat)
335!    CALL timing_start('bound_exch_generic')
336
337    ! Deal with optional routine arguments
338    lzeroarg = .TRUE.
339    lfillarg = .FALSE.
340    isgnarg = 1
341    zland = 0.0_wp
342
343    IF( PRESENT(lfill) ) lfillarg = lfill
344    IF( PRESENT(isgn)  ) isgnarg  = isgn
345    IF( PRESENT(lzero) ) lzeroarg = lzero
346    IF( PRESENT(pval)  ) zland    = pval 
347    iland=INT(zland)
348
349    ! Find out the size of 3rd dimension of the array
350
351    kdim1 = 1
352    IF ( PRESENT(b3) ) THEN
353#if defined key_z_first
354       kdim1 = SIZE(b3,dim=1)
355#else
356       kdim1 = SIZE(b3,dim=3)
357#endif
358    ELSEIF ( PRESENT(ib3) ) THEN
359#if defined key_z_first
360       kdim1 = SIZE(ib3,dim=1)
361#else
362       kdim1 = SIZE(ib3,dim=3)
363#endif
364    ELSEIF ( PRESENT(b2) ) THEN
365       kdim1 = SIZE(b2,dim=2)
366    ELSEIF ( PRESENT(ib2) ) THEN
367       kdim1 = SIZE(ib2,dim=2)
368    ENDIF
369
370    IF( lfillarg ) THEN
371
372       ! (nldi,nlej) is only a valid TL corner point if we're not on
373       ! an external boundary. If we are then we need nldi+1 if we
374       ! have cyclic E-W boundary conditions.
375       ileft = nldi
376       IF( (ilbext .AND. (.NOT. trimmed(widx,narea))) .AND. cyclic_bc) &
377                                                     ileft = ileft + 1
378
379       iright = nlei
380       IF( (iubext .AND. (.NOT. trimmed(eidx,narea))) .AND. cyclic_bc) &
381                                                    iright = iright - 1
382
383       IF ( PRESENT(b2) ) THEN
384          DO jj = 1, jprecj, 1   ! only fill extra allows last line
385             b2(nldi:nlei , jj) = b2(nldi:nlei, nldj)
386             b2(1:jpreci  , jj) = b2(ileft, nldj)  ! Bottom-left corner points
387             b2(nlci:jpi, jj)   = b2(iright, nldj) ! Bottom-right corner points
388          END DO
389
390          DO jj = nlej+1, jpj, 1   ! only fill extra allows last line
391             b2(nldi:nlei , jj) = b2(nldi:nlei, nlej)
392             b2(1:jpreci  , jj) = b2(ileft, nlej) ! Top-left corner points
393             b2(nlci:jpi, jj) = b2(iright, nlej)! Top-right corner points
394          END DO
395
396          DO jj = nldj,nlej,1 ! Left halo columns
397             b2(1: jpreci   , jj ) = b2(ileft, jj )
398          END DO
399
400          DO jj = nldj, nlej, 1 ! Right halo columns
401             b2(nlci:jpi    , jj ) = b2(iright, jj   )
402          END DO
403
404       ELSE IF ( PRESENT(ib2) ) THEN
405
406          DO jj = 1, jprecj   ! only fill extra allows last line
407             ib2(nldi:nlei  , jj) = ib2(nldi:nlei, nldj)
408             ib2(   1:jpreci, jj) = ib2(ileft    , nldj) ! Bottom-left corner points
409             ib2(nlci:jpi   , jj) = ib2(iright   , nldj) ! Bottom-right corner points
410          END DO
411
412          DO jj = nlej+1, jpj
413             ib2(nldi:nlei, jj) = ib2(nldi:nlei, nlej)
414             ib2(1:jpreci , jj) = ib2(ileft    , nlej) ! Top-left corner points
415             ib2(nlci:jpi , jj) = ib2(iright   , nlej) ! Top-right corner points
416          END DO
417
418          DO jj = nldj,nlej,1 ! West-most columns
419             ib2(1:jpreci, jj) = ib2(ileft, jj)
420          END DO
421
422          DO jj = nldj, nlej, 1 ! East-most columns
423             ib2(nlci:jpi, jj) = ib2(iright, jj)
424          END DO
425
426       ELSE IF ( PRESENT(b3) ) THEN
427
428#if defined key_z_first
429          DO jj = 1, jprecj, 1 ! Bottom rows
430             DO ii = nldi, nlei, 1
431                b3(ii, jj, 1:kdim1) = b3(ii, nldj, 1:kdim1) ! Bottom rows
432             END DO
433             DO ii = 1, jpreci, 1
434                b3(ii, jj, 1:kdim1) = b3(ileft    ,nldj,1:kdim1) ! Bottom-L corner
435             END DO
436             DO ii = nlci, jpi, 1
437                b3(ii, jj, 1:kdim1) = b3(iright   ,nldj,1:kdim1) ! Bottom-R corner
438             END DO
439          END DO
440
441          DO jj = nlej+1, jpj, 1 ! Top rows
442             DO ii = 1, jpreci, 1
443                b3(ii, jj,1:kdim1) = b3(ileft,nlej,1:kdim1) ! Top-L corner pts
444             END DO
445             DO ii = nldi, nlei, 1
446                b3(ii, jj,1:kdim1) = b3(ii,nlej,1:kdim1) ! Top rows
447             END DO
448             DO ii = nlci, jpi, 1
449                b3(ii , jj,1:kdim1) = b3(iright,nlej,1:kdim1) ! Top-R corner pts
450             END DO
451          END DO
452
453          DO jj = nldj, nlej, 1 ! E-most columns
454             DO ii = nlci, jpi, 1
455                b3(ii, jj, 1:kdim1) = b3(iright, jj, 1:kdim1)
456             END DO
457          END DO
458
459          DO jj = nldj, nlej, 1 ! W-most columns
460             DO ii = 1, jpreci, 1
461                b3(ii, jj, 1:kdim1) = b3(ileft, jj, 1:kdim1)
462             END DO
463          END DO
464#else
465          jk_loop: DO jk = 1,kdim1,1
466
467             DO jj = 1, jprecj, 1 ! Bottom rows
468                b3(nldi:nlei, jj, jk) = b3(nldi:nlei,nldj,jk) ! Bottom rows
469                b3(1:jpreci , jj, jk) = b3(ileft    ,nldj,jk) ! Bottom-L corner
470                b3(nlci:jpi , jj, jk) = b3(iright   ,nldj,jk) ! Bottom-R corner
471             END DO
472
473             DO jj = nlej+1, jpj, 1 ! Top rows
474                b3(nldi:nlei, jj,jk) = b3(nldi:nlei,nlej,jk) ! Top rows
475                b3(1:jpreci , jj,jk) = b3(ileft    ,nlej,jk) ! Top-L corner pts
476                b3(nlci:jpi , jj,jk) = b3(iright   ,nlej,jk) ! Top-R corner pts
477             END DO
478
479             DO jj = nldj, nlej, 1 ! E-most columns
480                b3(nlci:jpi, jj, jk) = b3(iright, jj, jk)
481             END DO
482
483             DO jj = nldj, nlej, 1 ! W-most columns
484                b3(1:jpreci, jj, jk) = b3(ileft, jj, jk)
485             END DO
486
487          END DO jk_loop
488#endif
489
490       ELSE IF ( PRESENT(ib3) ) THEN
491
492#if defined key_z_first
493          ! ARPDBG - do I need to make ii loops explicit and appropriately ordered?
494          DO jj = 1,jprecj ! Bottom rows
495             DO jk = 1,kdim1,1
496                ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
497                ib3(1:jpreci,  jj, jk) = ib3(ileft    ,nldj,jk) ! Bottom-L corner
498                ib3(nlci:jpi,jj, jk) = ib3(iright     ,nldj,jk) ! Bottom-R corner
499             END DO
500          END DO
501
502          DO jj = nlej+1, jpj ! Top rows
503             DO jk = 1,kdim1,1
504                ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
505                ib3(1:jpreci ,jj,jk) = ib3(ileft    ,nlej,jk) ! Top-L corner pts
506                ib3(nlci:jpi ,jj,jk) = ib3(iright   ,nlej,jk) ! Top-R corner pts
507             END DO
508          END DO
509
510          DO jj = nldj,nlej, 1 ! E-most columns
511             DO jk = 1,kdim1,1
512                ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
513             END DO
514          END DO
515
516          DO jj = nldj,nlej,1 ! W-most columns
517             DO jk = 1,kdim1,1
518                ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
519             END DO
520          END DO
521#else
522          DO jk = 1,kdim1,1
523
524             DO jj = 1,jprecj ! Bottom rows
525                ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
526                ib3(1:jpreci,  jj, jk) = ib3(ileft    ,nldj,jk) ! Bottom-L corner
527                ib3(nlci:jpi,jj, jk) = ib3(iright     ,nldj,jk) ! Bottom-R corner
528             END DO
529
530             DO jj = nlej+1, jpj ! Top rows
531                ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
532                ib3(1:jpreci ,jj,jk) = ib3(ileft    ,nlej,jk) ! Top-L corner pts
533                ib3(nlci:jpi ,jj,jk) = ib3(iright   ,nlej,jk) ! Top-R corner pts
534             END DO
535
536             DO jj = nldj,nlej, 1 ! E-most columns
537                ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
538             END DO
539
540             DO jj = nldj,nlej,1 ! W-most columns
541                ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
542             END DO
543
544          END DO
545#endif
546
547       END IF
548
549    ELSE ! lfillarg is .FALSE. - standard closed or cyclic treatment
550
551       !                                        ! East-West boundaries
552       !                                        ! ====================
553       !   nbondi == 2 when a single sub-domain spans the whole width
554       !   of the global domain
555       IF( nbondi == 2 .AND.   &      ! Cyclic east-west
556            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
557
558          IF ( PRESENT(b2) ) THEN
559
560             b2( 1 ,:) = b2(jpim1,:)   ! Set west halo to last valid east value
561             b2(jpi,:) = b2(nldi ,:)   ! east halo to first valid west value
562          ELSE IF ( PRESENT(ib2) ) THEN
563
564             ib2( 1 ,:) = ib2(jpim1,:)
565             ib2(jpi,:) = ib2(nldi ,:)
566          ELSE IF ( PRESENT(b3) ) THEN
567
568#if defined key_z_first
569             DO jj = 1,jpj,1
570                DO jk = 1,jpk,1
571                   b3( 1, jj, jk) = b3(jpim1, jj, jk)
572                   b3(jpi,jj, jk) = b3(    2, jj, jk)
573                END DO
574             END DO
575#else
576             b3( 1, :, :) = b3(jpim1, :, :)
577             b3(jpi,:, :) = b3(    2, :, :)
578#endif
579          ELSE IF ( PRESENT(ib3) ) THEN
580
581             ib3( 1, :, :) = ib3(jpim1, :, :)
582             ib3(jpi,:, :) = ib3(    2, :, :)
583          END IF
584
585       ELSE                           ! ... closed East-West boundaries
586
587          IF( lzeroarg )THEN
588
589             IF ( PRESENT(b2) ) THEN
590                SELECT CASE ( cd_type )
591                CASE ( 'T', 'U', 'V', 'W' , 'I' )
592                   b2(1:jpreci         , :) = zland ! Western halo
593                   b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo
594                CASE ( 'F' )
595                   b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo
596                END SELECT
597             ELSE IF ( PRESENT(ib2) ) THEN
598                SELECT CASE ( cd_type )
599                CASE ( 'T', 'U', 'V', 'W' , 'I' )
600                   ib2(1:jpreci         , :) = iland ! Western halo
601                   ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo
602                CASE ( 'F' )
603                   ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo
604                END SELECT
605             ELSE IF ( PRESENT(b3) ) THEN
606                SELECT CASE ( cd_type )
607                CASE ( 'T', 'U', 'V', 'W' )
608#if defined key_z_first
609                   DO jj=1,jpj,1
610                      DO ji=1,jpreci,1
611                         DO jk=1,jpk,1
612                            b3(ji, jj, jk) = zland
613                         END DO
614                      END DO
615                      DO ji=nlci-jpreci+1,jpi,1
616                         DO jk=1,jpk,1
617                            b3(ji, jj, jk) = zland
618                         END DO
619                      END DO
620                   END DO
621#else
622                   b3(1:jpreci         , :, :) = zland
623                   b3(nlci-jpreci+1:jpi, :, :) = zland
624#endif
625                CASE ( 'F' )
626#if defined key_z_first
627                   DO jj=1,jpj,1
628                      DO ji = nlci-jpreci+1,jpi,1
629                         DO jk = 1,jpk,1
630                            b3(ji, jj, jk) = zland
631                         END DO
632                      END DO
633                   END DO
634#else
635                   b3(nlci-jpreci+1:jpi, :, :) = zland
636#endif
637                END SELECT
638             ELSE IF ( PRESENT(ib3) ) THEN
639                SELECT CASE ( cd_type )
640                CASE ( 'T', 'U', 'V', 'W' )
641                   ib3(1:jpreci         , :, :) = iland
642                   ib3(nlci-jpreci+1:jpi, :, :) = iland
643                CASE ( 'F' )
644                   ib3(nlci-jpreci+1:jpi, :, :) = iland
645                END SELECT
646             END IF
647
648          END IF ! lzeroarg
649
650       END IF
651
652       IF( lzeroarg )THEN
653
654          !                             ! North-South boundaries (always closed)
655          !                             ! ======================
656          IF ( PRESENT(b2) ) THEN
657             SELECT CASE ( cd_type )
658             CASE ( 'T', 'U', 'V', 'W' , 'I' )
659                !b2(:,1:nldj-1         ) = zland
660                ! Below is what is done in original lib_mpp.F90
661                b2(:,1:jprecj         ) = zland
662                b2(:,nlcj-jprecj+1:jpj) = zland
663             CASE ( 'F' )
664                b2(:,nlcj-jprecj+1:jpj) = zland
665             END SELECT
666          ELSE IF ( PRESENT(ib2) ) THEN
667             SELECT CASE ( cd_type )
668             CASE ( 'T', 'U', 'V', 'W' , 'I' )
669                ib2(:,1:jprecj         ) = iland
670                ib2(:,nlcj-jprecj+1:jpj) = iland
671             CASE ( 'F' )
672                ib2(:,nlcj-jprecj+1:jpj) = iland
673             END SELECT
674          ELSE IF ( PRESENT(b3) ) THEN
675             SELECT CASE ( cd_type )
676             CASE ( 'T', 'U', 'V', 'W' )
677#if defined key_z_first
678                DO jj=1,jprecj,1
679                   DO ji=1,jpi,1
680                      DO jk = 1,jpk,1
681                         b3(ji, jj, jk) = zland
682                      END DO
683                   END DO
684                END DO
685                DO jj=nlcj-jprecj+1,jpj,1
686                   DO ji=1,jpi,1
687                      DO jk = 1,jpk,1
688                         b3(ji, jj, jk) = zland
689                      END DO
690                   END DO
691                END DO
692#else
693                b3(:, 1:jprecj         , :) = zland
694                b3(:, nlcj-jprecj+1:jpj, :) = zland
695#endif
696             CASE ( 'F' )
697#if defined key_z_first
698                DO jj=nlcj-jprecj+1,jpj,1
699                   DO ji=1,jpi,1
700                      DO jk = 1,jpk,1
701                         b3(ji, jj, jk) = zland
702                      END DO
703                   END DO
704                END DO
705#else
706                b3(:, nlcj-jprecj+1:jpj, :) = zland
707#endif
708             END SELECT
709          ELSE IF ( PRESENT(ib3) ) THEN
710             SELECT CASE ( cd_type )
711             CASE ( 'T', 'U', 'V', 'W' )
712                ib3(:, 1:jprecj         , :) = iland
713                ib3(:, nlcj-jprecj+1:jpj, :) = iland
714             CASE ( 'F' )
715                ib3(:, nlcj-jprecj+1:jpj, :) = iland
716             END SELECT
717          END IF
718
719       END IF ! lzeroarg
720
721    END IF ! lfillarg
722
723    ! Do East-West and North-South exchanges
724    CALL exchs_generic ( b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo,        &
725         nhexch=nhexch, handle=itag,                      &
726         comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
727         cd_type=cd_type, lfill=lfillarg)
728
729    !CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, &
730    !                    nhexch=nhexch, handle=itag,              &
731    !                    comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 )
732
733
734    ! Apply north-fold condition
735    IF(.not. lfillarg)THEN
736       IF(PRESENT(b2))THEN
737          CALL apply_north_fold(b2,  isgnarg, cd_type)
738       ELSE IF(PRESENT(ib2))THEN
739          CALL apply_north_fold(ib2, isgnarg, cd_type)
740       ELSE IF(PRESENT(b3))THEN
741          CALL apply_north_fold(b3,  isgnarg, cd_type)
742       ELSE IF(PRESENT(ib3))THEN
743          CALL apply_north_fold(ib3, isgnarg, cd_type)
744       ELSE
745          STOP 'ARPDBG: ERROR - no matching version of apply_north_fold!'
746       END IF
747
748
749       !WRITE (*,*) 'ARPDBG: bound_exch_generic: npolj = ',npolj
750       ! We only need to repeat the East and West halo swap if there
751       ! IS a north-fold in the configuration.
752       !SELECT CASE (npolj)
753
754       !CASE ( 3, 4, 5, 6 )
755       IF(ndim_rank_north > 0)THEN
756
757          ! Update East and West halos as required - no data sent north
758          ! as it's only the northern-most PEs that have been affected
759          ! by the north-fold condition.
760          ! ARPDBG - inefficient since all PEs do halo swap and only
761          ! those affected by the north fold actually need to - can
762          ! this be done within apply_north_fold?
763          CALL exchs_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, &
764                              nhexch=nhexch, handle=itag,               &
765                              comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
766                              cd_type=cd_type, lfill=lfillarg)
767
768          !CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, &
769          !                    nhexch=nhexch, handle=itag,              &
770          !                    comm1=Iplus,comm2=Iminus,comm3=NONE,comm4=NONE)
771          !                           comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 )
772       END IF        ! ndim_rank_north > 0
773       !END SELECT    ! npolj
774
775    END IF
776
777!    CALL prof_region_end(ARPCOMMS, iprofStat)
778!    CALL timing_stop('bound_exch_generic','section')
779
780  END SUBROUTINE bound_exch_generic
781
782  ! ------------------------------------------------------------------------
783
784  SUBROUTINE bound_exch_list ()
785    USE par_oce, ONLY: wp, jpreci, jprecj, jpim1
786    USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, &
787                       nperio, nbondi
788    USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc
789    IMPLICIT none
790    ! Local arguments
791    INTEGER :: ii, jj, jk, ifield    ! Loop indices
792    INTEGER :: ileft, iright ! First and last x-coord of internal points
793    INTEGER :: kdim1
794    INTEGER :: nfields
795!FTRANS b3  :I :I :z
796!FTRANS ib3 :I :I :z
797    INTEGER, DIMENSION(:,:),   POINTER :: ib2
798    INTEGER, DIMENSION(:,:,:), POINTER :: ib3
799    REAL, DIMENSION(:,:),   POINTER :: b2
800    REAL, DIMENSION(:,:,:), POINTER :: b3
801    !!----------------------------------------------------------------------
802
803#if ! defined key_mpp_rkpart
804    RETURN
805#endif
806
807    NULLIFY(ib2, ib3, b2, b3)
808
809    nfields = nextFreeExchItem - 1
810
811    CALL prof_region_begin(ARPLISTCOMMS, "ListComms", iprofStat)
812
813    DO ifield=1, nfields, 1
814
815       ! Find out the size of 3rd dimension of the array
816
817       kdim1 = 1
818       IF ( ASSOCIATED(exch_list(ifield)%r3dptr) ) THEN
819          b3 => exch_list(ifield)%r3dptr
820#if defined key_z_first
821          kdim1 = SIZE(b3,dim=1)
822#else
823          kdim1 = SIZE(b3,dim=3)
824#endif
825       ELSEIF ( ASSOCIATED(exch_list(ifield)%i3dptr) ) THEN
826          ib3 => exch_list(ifield)%i3dptr
827#if defined key_z_first
828          kdim1 = SIZE(ib3,dim=1)
829#else
830          kdim1 = SIZE(ib3,dim=3)
831#endif
832       ELSEIF ( ASSOCIATED(exch_list(ifield)%r2dptr) ) THEN
833          b2 => exch_list(ifield)%r2dptr
834          kdim1 = SIZE(b2,dim=2)
835       ELSEIF ( ASSOCIATED(exch_list(ifield)%i2dptr) ) THEN
836          ib2 => exch_list(ifield)%i2dptr
837          kdim1 = SIZE(ib2,dim=2)
838       ENDIF
839
840       IF( exch_list(ifield)%lfill ) THEN
841
842          ! (nldi,nlej) is only a valid TL corner point if we're not on an
843          ! external boundary. If we are AND we have cyclic E-W boundary
844          ! conditions then we need nldi+1.
845          ileft = nldi
846          IF(ilbext .AND. cyclic_bc)ileft = ileft + 1
847
848          iright = nlei
849          IF(iubext .AND. cyclic_bc)iright = iright - 1
850
851          IF ( ASSOCIATED(b2) ) THEN
852
853             DO jj = 1, jprecj, 1   ! only fill extra allows last line
854                b2(nldi:nlei , jj) = b2(nldi:nlei, nldj)
855                b2(1:jpreci  , jj) = b2(ileft, nldj) ! Bottom-left corner points
856                b2(nlci:jpi, jj) = b2(iright, nldj) ! Bottom-right corner points
857             END DO
858
859             DO jj = nlej+1, jpj, 1   ! only fill extra allows last line
860                b2(nldi:nlei , jj) = b2(nldi:nlei, nlej)
861                b2(1:jpreci  , jj) = b2(ileft, nlej) ! Top-left corner points
862                b2(nlci:jpi, jj) = b2(iright, nlej)! Top-right corner points
863             END DO
864         
865             DO jj = nldj,nlej,1 ! Left halo columns
866                b2(1: jpreci   , jj ) = b2(ileft, jj )
867             END DO
868
869             DO jj = nldj, nlej, 1 ! Right halo columns
870                b2(nlci:jpi    , jj ) = b2(iright, jj   )
871             END DO
872
873          ELSE IF ( ASSOCIATED(ib2) ) THEN
874
875               DO jj = 1, jprecj   ! only fill extra allows last line
876                  ib2(nldi:nlei  , jj) = ib2(nldi:nlei, nldj)
877                  ib2(   1:jpreci, jj) = ib2(ileft    , nldj) ! Bottom-left corner points
878                  ib2(nlci:jpi   , jj) = ib2(iright   , nldj) ! Bottom-right corner points
879               END DO
880
881               DO jj = nlej+1, jpj
882                  ib2(nldi:nlei, jj) = ib2(nldi:nlei, nlej)
883                  ib2(1:jpreci , jj) = ib2(ileft    , nlej) ! Top-left corner points
884                  ib2(nlci:jpi , jj) = ib2(iright   , nlej) ! Top-right corner points
885               END DO
886
887               DO jj = nldj,nlej,1 ! West-most columns
888                  ib2(1:jpreci, jj) = ib2(ileft, jj)
889               END DO
890
891               DO jj = nldj, nlej, 1 ! East-most columns
892                  ib2(nlci:jpi, jj) = ib2(iright, jj)
893               END DO
894
895            ELSE IF ( ASSOCIATED(b3) ) THEN
896
897#if defined key_z_first
898               DO jj = 1, jprecj, 1 ! Bottom rows
899                  DO ii = nldi, nlei, 1
900                     DO jk = 1,kdim1,1
901                        b3(ii, jj, jk) = b3(ii,nldj,jk) ! Bottom rows
902                     END DO
903                  END DO
904                  DO ii = 1, jpreci, 1
905                     DO jk = 1,kdim1,1
906                        b3(ii , jj, jk) = b3(ileft    ,nldj,jk) ! Bottom-L corner
907                     END DO
908                  END DO
909                  DO ii = nlci, jpi, 1
910                     DO jk = 1,kdim1,1
911                        b3(ii , jj, jk) = b3(iright   ,nldj,jk) ! Bottom-R corner
912                     END DO
913                  END DO
914               END DO
915
916               DO jj = nlej+1, jpj, 1 ! Top rows
917                  DO ii = nldi, nlei, 1
918                     DO jk = 1,kdim1,1
919                        b3(ii, jj,jk) = b3(ii,nlej,jk) ! Top rows
920                     END DO
921                  END DO
922                  DO ii = 1, jpreci, 1
923                     DO jk = 1,kdim1,1
924                        b3(ii, jj,jk) = b3(ileft,nlej,jk) ! Top-L corner pts
925                     END DO
926                  END DO
927                  DO ii = nlci, jpi, 1
928                     DO jk = 1,kdim1,1
929                        b3(ii,jj,jk) = b3(iright,nlej,jk) ! Top-R corner pts
930                     END DO
931                  END DO
932               END DO
933
934               DO jj = nldj, nlej, 1
935                  ! E-most columns
936                  DO ii = nlci, jpi, 1
937                     DO jk = 1,kdim1,1
938                        b3(ii, jj, jk) = b3(iright, jj, jk)
939                     END DO
940                  END DO
941
942                  ! W-most columns
943                  DO ii = 1, jpreci, 1
944                      DO jk = 1,kdim1,1
945                         b3(ii, jj, jk) = b3(ileft, jj, jk)
946                      END DO
947                  END DO
948               END DO
949#else
950               jk_loop: DO jk = 1,kdim1,1
951
952                  DO jj = 1, jprecj, 1 ! Bottom rows
953                     b3(nldi:nlei, jj, jk) = b3(nldi:nlei,nldj,jk) ! Bottom rows
954                     b3(1:jpreci , jj, jk) = b3(ileft    ,nldj,jk) ! Bottom-L corner
955                     b3(nlci:jpi , jj, jk) = b3(iright   ,nldj,jk) ! Bottom-R corner
956                  END DO
957
958                  DO jj = nlej+1, jpj, 1 ! Top rows
959                     b3(nldi:nlei, jj,jk) = b3(nldi:nlei,nlej,jk) ! Top rows
960                     b3(1:jpreci , jj,jk) = b3(ileft    ,nlej,jk) ! Top-L corner pts
961                     b3(nlci:jpi , jj,jk) = b3(iright   ,nlej,jk) ! Top-R corner pts
962                  END DO
963
964                  DO jj = nldj, nlej, 1 ! E-most columns
965                     b3(nlci:jpi, jj, jk) = b3(iright, jj, jk)
966                  END DO
967
968                  DO jj = nldj, nlej, 1 ! W-most columns
969                     b3(1:jpreci, jj, jk) = b3(ileft, jj, jk)
970                  END DO
971
972               END DO jk_loop
973#endif
974
975            ELSE IF ( ASSOCIATED(ib3) ) THEN
976#if defined key_z_first
977! ARPDBG need make loops over i explicit for optimum performance
978               DO jj = 1,jprecj ! Bottom rows
979                  DO jk = 1,kdim1,1
980                     ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
981                     ib3(1:jpreci,  jj, jk) = ib3(ileft    ,nldj,jk) ! Bottom-L corner
982                     ib3(nlci:jpi,jj, jk) = ib3(iright     ,nldj,jk) ! Bottom-R corner
983                  END DO
984               END DO
985
986               DO jj = nlej+1, jpj ! Top rows
987                  DO jk = 1,kdim1,1
988                     ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
989                     ib3(1:jpreci ,jj,jk) = ib3(ileft    ,nlej,jk) ! Top-L corner pts
990                     ib3(nlci:jpi ,jj,jk) = ib3(iright   ,nlej,jk) ! Top-R corner pts
991                  END DO
992               END DO
993
994               DO jj = nldj,nlej, 1 ! E-most columns
995                  DO jk = 1,kdim1,1
996                     ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
997                  END DO
998               END DO
999
1000               DO jj = nldj,nlej,1 ! W-most columns
1001                  DO jk = 1,kdim1,1
1002                     ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
1003                  END DO
1004               END DO
1005#else
1006               DO jk = 1,kdim1,1
1007
1008                  DO jj = 1,jprecj ! Bottom rows
1009                     ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
1010                     ib3(1:jpreci,  jj, jk) = ib3(ileft    ,nldj,jk) ! Bottom-L corner
1011                     ib3(nlci:jpi,jj, jk) = ib3(iright     ,nldj,jk) ! Bottom-R corner
1012                  END DO
1013
1014                  DO jj = nlej+1, jpj ! Top rows
1015                     ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
1016                     ib3(1:jpreci ,jj,jk) = ib3(ileft    ,nlej,jk) ! Top-L corner pts
1017                     ib3(nlci:jpi ,jj,jk) = ib3(iright   ,nlej,jk) ! Top-R corner pts
1018                  END DO
1019
1020                  DO jj = nldj,nlej, 1 ! E-most columns
1021                     ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
1022                  END DO
1023
1024                  DO jj = nldj,nlej,1 ! W-most columns
1025                     ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
1026                  END DO
1027
1028               END DO
1029#endif
1030
1031            END IF
1032
1033         ELSE ! lfill is .FALSE. for this field
1034
1035            !                                        ! East-West boundaries
1036            !                                        ! ====================
1037            IF( nbondi == 2 .AND.   &      ! Cyclic east-west
1038                 &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1039
1040               IF ( ASSOCIATED(b2) ) THEN
1041
1042                  b2( 1 ,:) = b2(jpim1,:)   ! Set west halo to last valid east value
1043                  b2(jpi,:) = b2(nldi ,:)   ! east halo to first valid west value
1044               ELSE IF ( ASSOCIATED(ib2) ) THEN
1045
1046                  ib2( 1 ,:) = ib2(jpim1,:)
1047                  ib2(jpi,:) = ib2(nldi ,:)
1048               ELSE IF ( ASSOCIATED(b3) ) THEN
1049
1050                  b3( 1, :, :) = b3(jpim1, :, :)
1051                  b3(jpi,:, :) = b3(    2, :, :)
1052               ELSE IF ( ASSOCIATED(ib3) ) THEN
1053
1054                  ib3( 1, :, :) = ib3(jpim1, :, :)
1055                  ib3(jpi,:, :) = ib3(    2, :, :)
1056               END IF
1057
1058            ELSE                           ! ... closed
1059
1060            END IF
1061
1062            !                                        ! North-South boundaries
1063            !                                        ! ======================
1064            IF ( ASSOCIATED(b2) ) THEN
1065               SELECT CASE ( exch_list(ifield)%grid )
1066               CASE ( 'T', 'U', 'V', 'W' , 'I' )
1067                  b2(:,1:jprecj         ) = 0.0_wp
1068                  b2(:,nlcj-jprecj+1:jpj) = 0.0_wp
1069               CASE ( 'F' )
1070                  b2(:,nlcj-jprecj+1:jpj) = 0.0_wp
1071               END SELECT
1072            ELSE IF ( ASSOCIATED(ib2) ) THEN
1073               SELECT CASE ( exch_list(ifield)%grid )
1074               CASE ( 'T', 'U', 'V', 'W' , 'I' )
1075                  ib2(:,1:jprecj         ) = 0
1076                  ib2(:,nlcj-jprecj+1:jpj) = 0
1077               CASE ( 'F' )
1078                  ib2(:,nlcj-jprecj+1:jpj) = 0
1079               END SELECT
1080            ELSE IF ( ASSOCIATED(b3) ) THEN
1081               SELECT CASE ( exch_list(ifield)%grid )
1082               CASE ( 'T', 'U', 'V', 'W' )
1083                  b3(:, 1:jprecj         , :) = 0.0_wp
1084                  b3(:, nlcj-jprecj+1:jpj, :) = 0.0_wp
1085               CASE ( 'F' )
1086                  b3(:, nlcj-jprecj+1:jpj, :) = 0.0_wp
1087               END SELECT
1088            ELSE IF ( ASSOCIATED(ib3) ) THEN
1089               SELECT CASE ( exch_list(ifield)%grid )
1090               CASE ( 'T', 'U', 'V', 'W' )
1091                  ib3(:, 1:jprecj         , :) = 0
1092                  ib3(:, nlcj-jprecj+1:jpj, :) = 0
1093               CASE ( 'F' )
1094                  ib3(:, nlcj-jprecj+1:jpj, :) = 0
1095               END SELECT
1096            END IF
1097
1098         END IF ! lfillarg
1099
1100      END DO ! loop over fields
1101
1102      ! Do East-West and North-South exchanges
1103      CALL exchs_generic_list ( exch_list, nfields )
1104
1105      ! Apply north-fold condition to those fields that need it and delete the
1106      ! others from the list
1107      CALL apply_north_fold_list(exch_list, nfields)
1108
1109      ! Update East and West halos on those fields that have just had the
1110      ! north-fold condition applied (will be the only ones left in the list
1111      ! as the others are removed within apply_north_fold_list.)
1112      ! ARPDBG - inefficient - can this be done within apply_north_fold?
1113      CALL exchs_generic_list (exch_list, nfields)
1114
1115      CALL prof_region_end(ARPLISTCOMMS, iprofStat)
1116
1117      DO ifield=1,nfields,1
1118         NULLIFY(exch_list(ifield)%r2dptr, exch_list(ifield)%r3dptr, &
1119                 exch_list(ifield)%i2dptr, exch_list(ifield)%i3dptr)
1120      END DO
1121
1122    nextFreeExchItem = 1
1123
1124  END SUBROUTINE bound_exch_list
1125
1126  !=========================================================================
1127
1128  SUBROUTINE apply_north_fold_list(list, nfields)
1129    USE par_oce, ONLY: wp, jpni, jpk
1130    USE dom_oce, ONLY: npolj
1131    IMPLICIT none
1132    ! Subroutine arguments.
1133    TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
1134    INTEGER,                           INTENT(in) :: nfields 
1135    ! Local variables
1136    INTEGER  :: ifield
1137    INTEGER  :: icount
1138
1139    icount = 0
1140
1141    DO ifield = 1, nfields, 1
1142
1143       IF(list(ifield)%lfill)THEN
1144          ! This field doesn't have north-fold condition applied to it
1145          ! so wipe its entry...
1146          CALL wipe_exch(list(ifield))
1147          icount = icount + 1
1148          ! ...and don't do any more with it
1149          CYCLE
1150       END IF
1151
1152    END DO
1153
1154    ! Check whether any of the fields need the north-fold condition
1155    ! applied
1156    IF(icount .eq. nfields)RETURN
1157
1158    ! Treatment without exchange (jpni odd)
1159
1160    SELECT CASE ( jpni )
1161
1162    CASE ( 1 ) ! only one proc along i, no mpp exchange
1163
1164       DO ifield = 1, nfields, 1
1165
1166          IF(ASSOCIATED(list(ifield)%r2dptr))THEN
1167
1168             CALL apply_north_fold_jpni1_2dr(list(ifield))
1169
1170          ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
1171
1172             CALL apply_north_fold_jpni1_3dr(list(ifield))
1173
1174          ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
1175
1176             CALL apply_north_fold_jpni1_2di(list(ifield))
1177
1178          ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
1179
1180             CALL apply_north_fold_jpni1_3di(list(ifield))
1181
1182          END IF
1183
1184
1185       END DO ! Loop over fields
1186
1187    CASE DEFAULT   ! more than 1 proc along I
1188
1189       DO ifield = 1, nfields, 1
1190          IF( npolj /= 0 .AND. do_nfold )THEN ! only for northern procs.
1191
1192             IF(ASSOCIATED(list(ifield)%r2dptr))THEN
1193
1194                CALL mpp_lbc_north( list(ifield)%r2dptr, list(ifield)%grid, &
1195                                    REAL(list(ifield)%isgn,wp) )
1196             ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
1197                CALL mpp_lbc_north( list(ifield)%r3dptr, list(ifield)%grid, &
1198                                    REAL(list(ifield)%isgn,wp) )
1199             ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
1200                CALL mpp_lbc_north( list(ifield)%i2dptr, list(ifield)%grid, &
1201                                    list(ifield)%isgn )
1202             ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
1203                CALL mpp_lbc_north( list(ifield)%i3dptr, list(ifield)%grid, &
1204                                    list(ifield)%isgn )
1205             END IF
1206
1207          END IF
1208       END DO
1209
1210!!$       IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs.
1211
1212    END SELECT   ! jpni
1213
1214  END SUBROUTINE apply_north_fold_list
1215
1216  !=========================================================================
1217
1218  SUBROUTINE apply_north_fold_jpni1_2dr(item)
1219    USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1220    USE lib_mpp, ONLY: ctl_stop
1221    IMPLICIT None
1222    TYPE (exch_item), INTENT(inout) :: item
1223    ! Locals
1224    INTEGER  :: iloc, ji, ijt, iju
1225    REAL(wp) :: psgn
1226    REAL(wp), DIMENSION(:,:), POINTER :: b2
1227
1228!#if defined key_z_first
1229!    CALL ctl_stop('STOP', &
1230!                  'apply_north_fold_jpni1_2dr: key_z_first not implemented for north fold')
1231!    RETURN
1232!#endif
1233
1234    psgn = REAL(item%isgn, wp)
1235    b2 => item%r2dptr
1236
1237    SELECT CASE ( npolj )
1238
1239    CASE ( 3 , 4 )   !  T pivot
1240       iloc = jpiglo - 2 * ( nimpp - 1 )
1241       
1242       SELECT CASE ( item%grid )
1243
1244       CASE ( 'T' , 'S', 'W' )
1245          DO ji = 2, nlci
1246             ijt=iloc-ji+2
1247             b2(ji,nlcj) = psgn * b2(ijt,nlcj-2)
1248          END DO
1249          DO ji = nlci/2+1, nlci
1250             ijt=iloc-ji+2
1251             b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1252          END DO
1253
1254       CASE ( 'U' )
1255          DO ji = 1, nlci-1
1256             iju=iloc-ji+1
1257             b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1258          END DO
1259          DO ji = nlci/2, nlci-1
1260             iju=iloc-ji+1
1261             b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1262          END DO
1263               
1264       CASE ( 'V' )
1265          DO ji = 2, nlci
1266             ijt=iloc-ji+2
1267             b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-2)
1268             b2(ji,nlcj  ) = psgn * b2(ijt,nlcj-3)
1269          END DO
1270
1271       CASE ( 'F', 'G' )
1272          DO ji = 1, nlci-1
1273             iju=iloc-ji+1
1274             b2(ji,nlcj-1) = psgn * b2(iju,nlcj-2)
1275             b2(ji,nlcj  ) = psgn * b2(iju,nlcj-3)
1276          END DO
1277
1278       CASE ( 'I' )                                  ! ice U-V point
1279          b2(2,nlcj) = psgn * b2(3,nlcj-1)
1280          DO ji = 3, nlci
1281             iju = iloc - ji + 3
1282             b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1283          END DO
1284
1285       END SELECT
1286
1287    CASE ( 5 , 6 )                 ! F pivot
1288       iloc=jpiglo-2*(nimpp-1)
1289
1290       SELECT CASE (item%grid)
1291             
1292       CASE ( 'T', 'S', 'W' )
1293          DO ji = 1, nlci
1294             ijt=iloc-ji+1
1295             b2(ji,nlcj) = psgn * b2(ijt,nlcj-1)
1296          END DO
1297
1298       CASE ( 'U' )
1299          DO ji = 1, nlci-1
1300             iju=iloc-ji
1301             b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1302          END DO
1303
1304       CASE ( 'V' )
1305          DO ji = 1, nlci
1306             ijt=iloc-ji+1
1307             b2(ji,nlcj  ) = psgn * b2(ijt,nlcj-2)
1308          END DO
1309          DO ji = nlci/2+1, nlci
1310             ijt=iloc-ji+1
1311             b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1312          END DO
1313
1314       CASE ( 'F', 'G' )
1315          DO ji = 1, nlci-1
1316             iju=iloc-ji
1317             b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1318          END DO
1319          DO ji = nlci/2+1, nlci-1
1320             iju=iloc-ji
1321             b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1322          END DO
1323
1324       CASE ( 'I' )                                  ! ice U-V point
1325          b2( 2 ,nlcj) = 0._wp
1326          DO ji = 2 , nlci-1
1327             ijt = iloc - ji + 2
1328             b2(ji,nlcj)= 0.5 * ( b2(ji,nlcj-1) + psgn * b2(ijt,nlcj-1) )
1329          END DO
1330             
1331       END SELECT   ! cd_type
1332         
1333    END SELECT   ! npolj
1334
1335  END SUBROUTINE apply_north_fold_jpni1_2dr
1336
1337  !=========================================================================
1338
1339  SUBROUTINE apply_north_fold_jpni1_3dr(item)
1340    USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1341    USE lib_mpp, ONLY: ctl_stop
1342    IMPLICIT None
1343    TYPE (exch_item), INTENT(inout) :: item
1344!FTRANS b3 :I :I :z
1345    ! Locals
1346    INTEGER  :: iloc, ji, jk, ijt, iju
1347    REAL(wp) :: psgn
1348    REAL(wp), DIMENSION(:,:,:), POINTER :: b3
1349
1350!#if defined key_z_first
1351!    CALL ctl_stop('STOP', &
1352!                  'apply_north_fold_jpni1_3dr: key_z_first not implemented for north fold')
1353!    RETURN
1354!#endif
1355
1356    psgn = REAL(item%isgn, wp)
1357    b3 => item%r3dptr
1358
1359    SELECT CASE ( npolj )
1360
1361    CASE ( 3 , 4 )    ! T pivot
1362       iloc = jpiglo - 2 * ( nimpp - 1 )
1363
1364       SELECT CASE ( item%grid )
1365
1366       CASE ( 'T' , 'S', 'W' )
1367#if defined key_z_first
1368          DO ji = 2, nlci
1369             DO jk = 1, jpk
1370                ijt=iloc-ji+2
1371                b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
1372             END DO
1373          END DO
1374          DO ji = nlci/2+1, nlci
1375             DO jk = 1, jpk
1376                ijt=iloc-ji+2
1377                b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1378             END DO
1379          END DO
1380#else
1381         DO jk = 1, jpk
1382             DO ji = 2, nlci
1383                ijt=iloc-ji+2
1384                b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
1385             END DO
1386             DO ji = nlci/2+1, nlci
1387                ijt=iloc-ji+2
1388                b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1389             END DO
1390          END DO
1391#endif
1392
1393       CASE ( 'U' )
1394#if defined key_z_first
1395          DO ji = 1, nlci-1
1396             DO jk = 1, jpk
1397                iju=iloc-ji+1
1398                b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1399             END DO
1400          END DO
1401          DO ji = nlci/2, nlci-1
1402             DO jk = 1, jpk
1403                iju=iloc-ji+1
1404                b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1405             END DO
1406          END DO
1407#else
1408          DO jk = 1, jpk
1409             DO ji = 1, nlci-1
1410                iju=iloc-ji+1
1411                b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1412             END DO
1413             DO ji = nlci/2, nlci-1
1414                iju=iloc-ji+1
1415                b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1416             END DO
1417          END DO
1418#endif
1419
1420       CASE ( 'V' )
1421#if defined key_z_first
1422          DO ji = 2, nlci
1423             DO jk = 1, jpk
1424#else
1425          DO jk = 1, jpk
1426             DO ji = 2, nlci
1427#endif
1428                ijt=iloc-ji+2
1429                b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-2,jk)
1430                b3(ji,nlcj  ,jk) = psgn * b3(ijt,nlcj-3,jk)
1431             END DO
1432          END DO
1433
1434       CASE ( 'F', 'G' )
1435#if defined key_z_first
1436          DO ji = 1, nlci-1
1437             DO jk = 1, jpk
1438#else
1439          DO jk = 1, jpk
1440             DO ji = 1, nlci-1
1441#endif
1442                iju=iloc-ji+1
1443                b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-2,jk)
1444                b3(ji,nlcj  ,jk) = psgn * b3(iju,nlcj-3,jk)
1445             END DO
1446          END DO
1447
1448       END SELECT
1449
1450    CASE ( 5 , 6 ) ! F pivot
1451       iloc=jpiglo-2*(nimpp-1)
1452
1453       SELECT CASE ( item%grid )
1454
1455       CASE ( 'T' , 'S', 'W' )
1456#if defined key_z_first
1457          DO ji = 1, nlci
1458             DO jk = 1, jpk
1459#else
1460          DO jk = 1, jpk
1461             DO ji = 1, nlci
1462#endif
1463                ijt=iloc-ji+1
1464                b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-1,jk)
1465             END DO
1466          END DO
1467
1468       CASE ( 'U' )
1469#if defined key_z_first
1470          DO ji = 1, nlci-1
1471             DO jk = 1, jpk
1472#else
1473          DO jk = 1, jpk
1474             DO ji = 1, nlci-1
1475#endif
1476                iju=iloc-ji
1477                b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-1,jk)
1478             END DO
1479          END DO
1480
1481       CASE ( 'V' )
1482#if defined key_z_first
1483          DO ji = 1, nlci
1484             DO jk = 1, jpk
1485                ijt=iloc-ji+1
1486                b3(ji,nlcj  ,jk) = psgn * b3(ijt,nlcj-2,jk)
1487             END DO
1488          END DO
1489          DO ji = nlci/2+1, nlci
1490             DO jk = 1, jpk
1491                ijt=iloc-ji+1
1492                b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1493             END DO
1494          END DO
1495#else
1496          DO jk = 1, jpk
1497             DO ji = 1, nlci
1498                ijt=iloc-ji+1
1499                b3(ji,nlcj  ,jk) = psgn * b3(ijt,nlcj-2,jk)
1500             END DO
1501             DO ji = nlci/2+1, nlci
1502                ijt=iloc-ji+1
1503                b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1504             END DO
1505          END DO
1506#endif
1507
1508       CASE ( 'F', 'G' )
1509#if defined key_z_first
1510          DO ji = 1, nlci-1
1511             DO jk = 1, jpk
1512                iju=iloc-ji
1513                b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1514             END DO
1515          END DO
1516          DO ji = nlci/2+1, nlci-1
1517             DO jk = 1, jpk
1518                iju=iloc-ji
1519                b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1520             END DO
1521          END DO
1522#else
1523          DO jk = 1, jpk
1524             DO ji = 1, nlci-1
1525                iju=iloc-ji
1526                b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1527             END DO
1528             DO ji = nlci/2+1, nlci-1
1529                iju=iloc-ji
1530                b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1531             END DO
1532          END DO
1533#endif
1534       END SELECT  ! item%grid type
1535
1536    END SELECT     ! npolj
1537
1538  END SUBROUTINE apply_north_fold_jpni1_3dr
1539
1540  !=========================================================================
1541
1542  SUBROUTINE apply_north_fold_jpni1_2di(item)
1543    USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1544    USE lib_mpp, ONLY: ctl_stop
1545    IMPLICIT None
1546    TYPE (exch_item), INTENT(inout) :: item
1547    ! Locals
1548    INTEGER  :: iloc, ji, ijt, iju
1549    INTEGER  :: isgn
1550    INTEGER, DIMENSION(:,:), POINTER :: ib2
1551
1552    isgn = item%isgn
1553    ib2 => item%i2dptr
1554
1555    SELECT CASE ( npolj )
1556
1557    CASE ( 3 , 4 )   !  T pivot
1558       iloc = jpiglo - 2 * ( nimpp - 1 )
1559             
1560       SELECT CASE ( item%grid )
1561
1562       CASE ( 'T' , 'S', 'W' )
1563          DO ji = 2, nlci
1564             ijt=iloc-ji+2
1565             ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-2)
1566          END DO
1567          DO ji = nlci/2+1, nlci
1568             ijt=iloc-ji+2
1569             ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
1570          END DO
1571
1572       CASE ( 'U' )
1573          DO ji = 1, nlci-1
1574             iju=iloc-ji+1
1575             ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
1576          END DO
1577          DO ji = nlci/2, nlci-1
1578             iju=iloc-ji+1
1579             ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
1580          END DO
1581
1582       CASE ( 'V' )
1583          DO ji = 2, nlci
1584             ijt=iloc-ji+2
1585             ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-2)
1586             ib2(ji,nlcj  ) = isgn * ib2(ijt,nlcj-3)
1587          END DO
1588
1589       CASE ( 'F', 'G' )
1590          DO ji = 1, nlci-1
1591             iju=iloc-ji+1
1592             ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-2)
1593             ib2(ji,nlcj  ) = isgn * ib2(iju,nlcj-3)
1594          END DO
1595
1596       CASE ( 'I' )                                  ! ice U-V point
1597          ib2(2,nlcj) = isgn * ib2(3,nlcj-1)
1598          DO ji = 3, nlci
1599             iju = iloc - ji + 3
1600             ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
1601          END DO
1602
1603       END SELECT
1604
1605    CASE ( 5 , 6 )                 ! F pivot
1606       iloc=jpiglo-2*(nimpp-1)
1607       
1608       SELECT CASE (item%grid)
1609             
1610       CASE ( 'T', 'S', 'W' )
1611          DO ji = 1, nlci
1612             ijt=iloc-ji+1
1613             ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-1)
1614          END DO
1615         
1616       CASE ( 'U' )
1617          DO ji = 1, nlci-1
1618             iju=iloc-ji
1619             ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
1620          END DO
1621
1622       CASE ( 'V' )
1623          DO ji = 1, nlci
1624             ijt=iloc-ji+1
1625             ib2(ji,nlcj  ) = isgn * ib2(ijt,nlcj-2)
1626          END DO
1627          DO ji = nlci/2+1, nlci
1628             ijt=iloc-ji+1
1629             ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
1630          END DO
1631
1632       CASE ( 'F', 'G' )
1633          DO ji = 1, nlci-1
1634             iju=iloc-ji
1635             ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
1636          END DO
1637          DO ji = nlci/2+1, nlci-1
1638             iju=iloc-ji
1639             ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
1640          END DO
1641
1642       CASE ( 'I' )                                  ! ice U-V point
1643          ib2( 2 ,nlcj) = 0._wp
1644          DO ji = 2 , nlci-1
1645             ijt = iloc - ji + 2
1646             ib2(ji,nlcj)= INT(0.5 * ( ib2(ji,nlcj-1) + isgn * ib2(ijt,nlcj-1) ))
1647          END DO
1648             
1649       END SELECT   ! cd_type
1650         
1651    END SELECT   ! npolj
1652
1653  END SUBROUTINE apply_north_fold_jpni1_2di
1654
1655  !=========================================================================
1656
1657  SUBROUTINE apply_north_fold_jpni1_3di(item)
1658    USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1659    USE lib_mpp, ONLY: ctl_stop
1660    IMPLICIT None
1661    TYPE (exch_item), INTENT(inout) :: item
1662!FTRANS ib3 :I :I :z
1663    ! Locals
1664    INTEGER  :: iloc, ji, ijt, iju, jk
1665    INTEGER  :: isgn
1666    INTEGER, DIMENSION(:,:,:), POINTER :: ib3
1667
1668    isgn = item%isgn
1669    ib3 => item%i3dptr
1670
1671    SELECT CASE ( npolj )
1672
1673    CASE ( 3 , 4 )    ! T pivot
1674       iloc = jpiglo - 2 * ( nimpp - 1 )
1675
1676       SELECT CASE ( item%grid )
1677
1678       CASE ( 'T' , 'S', 'W' )
1679#if defined key_z_first
1680          DO ji = 2, nlci
1681             DO jk = 1, jpk
1682                ijt=iloc-ji+2
1683                ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
1684             END DO
1685          END DO
1686          DO ji = nlci/2+1, nlci
1687             DO jk = 1, jpk
1688                ijt=iloc-ji+2
1689                ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1690             END DO
1691          END DO
1692#else
1693          DO jk = 1, jpk
1694             DO ji = 2, nlci
1695                ijt=iloc-ji+2
1696                ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
1697             END DO
1698             DO ji = nlci/2+1, nlci
1699                ijt=iloc-ji+2
1700                ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1701             END DO
1702          END DO
1703#endif
1704
1705       CASE ( 'U' )
1706#if defined key_z_first
1707          DO ji = 1, nlci-1
1708             DO jk = 1, jpk
1709                iju=iloc-ji+1
1710                ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1711             END DO
1712          END DO
1713          DO ji = nlci/2, nlci-1
1714             DO jk = 1, jpk
1715                iju=iloc-ji+1
1716                ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1717             END DO
1718          END DO
1719#else
1720          DO jk = 1, jpk
1721             DO ji = 1, nlci-1
1722                iju=iloc-ji+1
1723                ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1724             END DO
1725             DO ji = nlci/2, nlci-1
1726                iju=iloc-ji+1
1727                ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1728             END DO
1729          END DO
1730#endif
1731
1732       CASE ( 'V' )
1733#if defined key_z_first
1734          DO ji = 2, nlci
1735             DO jk = 1, jpk
1736#else
1737          DO jk = 1, jpk
1738             DO ji = 2, nlci
1739#endif
1740                ijt=iloc-ji+2
1741                ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-2,jk)
1742                ib3(ji,nlcj  ,jk) = isgn * ib3(ijt,nlcj-3,jk)
1743             END DO
1744          END DO
1745
1746       CASE ( 'F', 'G' )
1747#if defined key_z_first
1748          DO ji = 1, nlci-1
1749             DO jk = 1, jpk
1750#else
1751          DO jk = 1, jpk
1752             DO ji = 1, nlci-1
1753#endif
1754                iju=iloc-ji+1
1755                ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-2,jk)
1756                ib3(ji,nlcj  ,jk) = isgn * ib3(iju,nlcj-3,jk)
1757             END DO
1758          END DO
1759
1760       END SELECT
1761
1762    CASE ( 5 , 6 ) ! F pivot
1763       iloc=jpiglo-2*(nimpp-1)
1764
1765       SELECT CASE ( item%grid )
1766         
1767       CASE ( 'T' , 'S', 'W' )
1768#if defined key_z_first
1769          DO ji = 1, nlci
1770             DO jk = 1, jpk
1771#else
1772          DO jk = 1, jpk
1773             DO ji = 1, nlci
1774#endif
1775                ijt=iloc-ji+1
1776                ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-1,jk)
1777             END DO
1778          END DO
1779
1780       CASE ( 'U' )
1781#if defined key_z_first
1782          DO ji = 1, nlci-1
1783             DO jk = 1, jpk
1784#else
1785          DO jk = 1, jpk
1786             DO ji = 1, nlci-1
1787#endif
1788                iju=iloc-ji
1789                ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-1,jk)
1790             END DO
1791          END DO
1792
1793       CASE ( 'V' )
1794#if defined key_z_first
1795          DO ji = 1, nlci
1796             DO jk = 1, jpk
1797                ijt=iloc-ji+1
1798                ib3(ji,nlcj  ,jk) = isgn * ib3(ijt,nlcj-2,jk)
1799             END DO
1800          END DO
1801          DO ji = nlci/2+1, nlci
1802             DO jk = 1, jpk
1803                ijt=iloc-ji+1
1804                ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1805             END DO
1806          END DO
1807#else
1808          DO jk = 1, jpk
1809             DO ji = 1, nlci
1810                ijt=iloc-ji+1
1811                ib3(ji,nlcj  ,jk) = isgn * ib3(ijt,nlcj-2,jk)
1812             END DO
1813             DO ji = nlci/2+1, nlci
1814                ijt=iloc-ji+1
1815                ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1816             END DO
1817          END DO
1818#endif
1819
1820       CASE ( 'F', 'G' )
1821#if defined key_z_first
1822          DO ji = 1, nlci-1
1823             DO jk = 1, jpk
1824                iju=iloc-ji
1825                ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1826             END DO
1827          END DO
1828          DO ji = nlci/2+1, nlci-1
1829             DO jk = 1, jpk
1830                iju=iloc-ji
1831                ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1832             END DO
1833          END DO
1834#else
1835          DO jk = 1, jpk
1836             DO ji = 1, nlci-1
1837                iju=iloc-ji
1838                ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1839             END DO
1840             DO ji = nlci/2+1, nlci-1
1841                iju=iloc-ji
1842                ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1843             END DO
1844          END DO
1845#endif
1846       END SELECT  ! item%grid type
1847
1848    END SELECT     ! npolj
1849
1850  END SUBROUTINE apply_north_fold_jpni1_3di
1851
1852  !=========================================================================
1853
1854  SUBROUTINE apply_north_fold2(b2, isgn, cd_type)
1855    USE par_oce, ONLY: wp, jpni, jpk
1856    USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1857    USE lib_mpp, ONLY: ctl_stop
1858    IMPLICIT none
1859    REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(1:, 1:) :: b2
1860    INTEGER,                                 INTENT(in) :: isgn
1861    CHARACTER (LEN=1),                       INTENT(in) :: cd_type
1862    ! Local variables
1863    INTEGER  :: ji, ijt, iju, iloc
1864    REAL(wp) :: psgn
1865
1866    psgn = REAL(isgn, wp)
1867
1868    ! Treatment without exchange (jpni odd)
1869
1870    SELECT CASE ( jpni )
1871
1872    CASE ( 1 ) ! only one proc along I, no mpp exchange
1873
1874       SELECT CASE ( npolj )
1875
1876       CASE ( 3 , 4 )   !  T pivot
1877          iloc = jpiglo - 2 * ( nimpp - 1 )
1878             
1879          SELECT CASE ( cd_type )
1880
1881          CASE ( 'T' , 'S', 'W' )
1882             DO ji = 2, nlci
1883                ijt=iloc-ji+2
1884                b2(ji,nlcj) = psgn * b2(ijt,nlcj-2)
1885             END DO
1886             DO ji = nlci/2+1, nlci
1887                ijt=iloc-ji+2
1888                b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1889             END DO
1890
1891          CASE ( 'U' )
1892             DO ji = 1, nlci-1
1893                iju=iloc-ji+1
1894                b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1895             END DO
1896             DO ji = nlci/2, nlci-1
1897                iju=iloc-ji+1
1898                b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1899             END DO
1900
1901          CASE ( 'V' )
1902             DO ji = 2, nlci
1903                ijt=iloc-ji+2
1904                b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-2)
1905                b2(ji,nlcj  ) = psgn * b2(ijt,nlcj-3)
1906             END DO
1907
1908          CASE ( 'F', 'G' )
1909             DO ji = 1, nlci-1
1910                iju=iloc-ji+1
1911                b2(ji,nlcj-1) = psgn * b2(iju,nlcj-2)
1912                b2(ji,nlcj  ) = psgn * b2(iju,nlcj-3)
1913             END DO
1914
1915          CASE ( 'I' )                                  ! ice U-V point
1916             b2(2,nlcj) = psgn * b2(3,nlcj-1)
1917             DO ji = 3, nlci
1918                iju = iloc - ji + 3
1919                b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1920             END DO
1921
1922          END SELECT
1923
1924       CASE ( 5 , 6 )                 ! F pivot
1925          iloc=jpiglo-2*(nimpp-1)
1926
1927          SELECT CASE (cd_type )
1928             
1929          CASE ( 'T', 'S', 'W' )
1930             DO ji = 1, nlci
1931                ijt=iloc-ji+1
1932                b2(ji,nlcj) = psgn * b2(ijt,nlcj-1)
1933             END DO
1934
1935          CASE ( 'U' )
1936             DO ji = 1, nlci-1
1937                iju=iloc-ji
1938                b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1939             END DO
1940
1941          CASE ( 'V' )
1942             DO ji = 1, nlci
1943                ijt=iloc-ji+1
1944                b2(ji,nlcj  ) = psgn * b2(ijt,nlcj-2)
1945             END DO
1946             DO ji = nlci/2+1, nlci
1947                ijt=iloc-ji+1
1948                b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1949             END DO
1950
1951          CASE ( 'F', 'G' )
1952             DO ji = 1, nlci-1
1953                iju=iloc-ji
1954                b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1955             END DO
1956             DO ji = nlci/2+1, nlci-1
1957                iju=iloc-ji
1958                b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1959             END DO
1960
1961          CASE ( 'I' )                                  ! ice U-V point
1962             b2( 2 ,nlcj) = 0._wp
1963             DO ji = 2 , nlci-1
1964                ijt = iloc - ji + 2
1965                b2(ji,nlcj)= 0.5 * ( b2(ji,nlcj-1) + psgn * b2(ijt,nlcj-1) )
1966             END DO
1967             
1968          END SELECT   ! cd_type
1969         
1970       END SELECT   ! npolj
1971
1972    CASE DEFAULT   ! more than 1 proc along I
1973       IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north( b2, cd_type, psgn )   ! only for northern procs.
1974
1975    END SELECT   ! jpni
1976
1977  END SUBROUTINE apply_north_fold2
1978
1979  !=========================================================================
1980
1981  SUBROUTINE apply_north_fold2i(ib2, isgn, cd_type)
1982    USE par_oce, ONLY: wp, jpni, jpk
1983    USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1984    USE lib_mpp, ONLY: ctl_stop
1985    IMPLICIT none
1986    INTEGER, INTENT(inout), DIMENSION(1:, 1:) :: ib2
1987    INTEGER,                       INTENT(in) :: isgn
1988    CHARACTER (LEN=1),             INTENT(in) :: cd_type
1989    ! Local variables
1990    INTEGER  :: ji, ijt, iju, iloc
1991
1992
1993#if defined key_z_first
1994    CALL ctl_stop('STOP', &
1995                  'apply_north_fold2i: key_z_first not implemented for north fold')
1996    RETURN
1997#endif
1998
1999    ! Treatment without exchange (jpni odd)
2000
2001    SELECT CASE ( jpni )
2002
2003    CASE ( 1 ) ! only one proc along I, no mpp exchange
2004
2005       SELECT CASE ( npolj )
2006
2007       CASE ( 3 , 4 )   !  T pivot
2008          iloc = jpiglo - 2 * ( nimpp - 1 )
2009             
2010          SELECT CASE ( cd_type )
2011
2012          CASE ( 'T' , 'S', 'W' )
2013             DO ji = 2, nlci
2014                ijt=iloc-ji+2
2015                ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-2)
2016             END DO
2017             DO ji = nlci/2+1, nlci
2018                ijt=iloc-ji+2
2019                ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
2020             END DO
2021
2022          CASE ( 'U' )
2023             DO ji = 1, nlci-1
2024                iju=iloc-ji+1
2025                ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
2026             END DO
2027             DO ji = nlci/2, nlci-1
2028                iju=iloc-ji+1
2029                ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
2030             END DO
2031
2032          CASE ( 'V' )
2033             DO ji = 2, nlci
2034                ijt=iloc-ji+2
2035                ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-2)
2036                ib2(ji,nlcj  ) = isgn * ib2(ijt,nlcj-3)
2037             END DO
2038
2039          CASE ( 'F', 'G' )
2040             DO ji = 1, nlci-1
2041                iju=iloc-ji+1
2042                ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-2)
2043                ib2(ji,nlcj  ) = isgn * ib2(iju,nlcj-3)
2044             END DO
2045
2046          CASE ( 'I' )                                  ! ice U-V point
2047             ib2(2,nlcj) = isgn * ib2(3,nlcj-1)
2048             DO ji = 3, nlci
2049                iju = iloc - ji + 3
2050                ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
2051             END DO
2052
2053          END SELECT
2054
2055       CASE ( 5 , 6 )                 ! F pivot
2056          iloc=jpiglo-2*(nimpp-1)
2057
2058          SELECT CASE (cd_type )
2059             
2060          CASE ( 'T', 'S', 'W' )
2061             DO ji = 1, nlci
2062                ijt=iloc-ji+1
2063                ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-1)
2064             END DO
2065
2066          CASE ( 'U' )
2067             DO ji = 1, nlci-1
2068                iju=iloc-ji
2069                ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
2070             END DO
2071
2072          CASE ( 'V' )
2073             DO ji = 1, nlci
2074                ijt=iloc-ji+1
2075                ib2(ji,nlcj  ) = isgn * ib2(ijt,nlcj-2)
2076             END DO
2077             DO ji = nlci/2+1, nlci
2078                ijt=iloc-ji+1
2079                ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
2080             END DO
2081
2082          CASE ( 'F', 'G' )
2083             DO ji = 1, nlci-1
2084                iju=iloc-ji
2085                ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
2086             END DO
2087             DO ji = nlci/2+1, nlci-1
2088                iju=iloc-ji
2089                ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
2090             END DO
2091
2092          CASE ( 'I' )                                  ! ice U-V point
2093             ib2( 2 ,nlcj) = 0._wp
2094             DO ji = 2 , nlci-1
2095                ijt = iloc - ji + 2
2096                ib2(ji,nlcj)= INT(0.5 * ( ib2(ji,nlcj-1) + isgn * ib2(ijt,nlcj-1) ))
2097             END DO
2098             
2099          END SELECT   ! cd_type
2100         
2101       END SELECT   ! npolj
2102
2103    CASE DEFAULT   ! more than 1 proc along I
2104       IF( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north( ib2, cd_type, isgn )   ! only for northern procs.
2105
2106    END SELECT   ! jpni
2107
2108  END SUBROUTINE apply_north_fold2i
2109
2110  !=========================================================================
2111
2112  SUBROUTINE apply_north_fold3(b3, isgn, cd_type)
2113    USE par_oce, ONLY: wp, jpni, jpk
2114    USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
2115    USE lib_mpp, ONLY: ctl_stop
2116    IMPLICIT none
2117!FTRANS b3 :I :I :z
2118    REAL(wp), INTENT(inout), DIMENSION(1:, 1:, 1:) :: b3
2119    INTEGER,                            INTENT(in) :: isgn
2120    CHARACTER (LEN=1),                  INTENT(in) :: cd_type
2121    ! Local variables
2122    INTEGER  :: ji, jk, ijt, iju, iloc
2123    REAL(wp) :: psgn
2124    !!----------------------------------------------------------------------
2125
2126    psgn = REAL(isgn, wp)
2127
2128    ! Treatment without exchange (jpni odd)
2129    ! T-point pivot 
2130
2131    SELECT CASE ( jpni )
2132
2133    CASE ( 1 )  ! only one proc along I, no mpp exchange
2134
2135       SELECT CASE ( npolj )
2136
2137       CASE ( 3 , 4 )    ! T pivot
2138          iloc = jpiglo - 2 * ( nimpp - 1 )
2139
2140          SELECT CASE ( cd_type )
2141
2142          CASE ( 'T' , 'S', 'W' )
2143#if defined key_z_first
2144             DO ji = 2, nlci
2145                DO jk = 1, jpk
2146                   ijt=iloc-ji+2
2147                   b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
2148                END DO
2149             END DO
2150             DO ji = nlci/2+1, nlci
2151                DO jk = 1, jpk
2152                   ijt=iloc-ji+2
2153                   b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2154                END DO
2155             END DO
2156#else
2157             DO jk = 1, jpk
2158                DO ji = 2, nlci
2159                   ijt=iloc-ji+2
2160                   b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
2161                END DO
2162                DO ji = nlci/2+1, nlci
2163                   ijt=iloc-ji+2
2164                   b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2165                END DO
2166             END DO
2167#endif
2168
2169          CASE ( 'U' )
2170#if defined key_z_first
2171             DO ji = 1, nlci-1
2172                DO jk = 1, jpk
2173                   iju=iloc-ji+1
2174                   b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2175                END DO
2176             END DO
2177             DO ji = nlci/2, nlci-1
2178                DO jk = 1, jpk
2179                   iju=iloc-ji+1
2180                   b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2181                END DO
2182             END DO
2183#else
2184             DO jk = 1, jpk
2185                DO ji = 1, nlci-1
2186                   iju=iloc-ji+1
2187                   b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2188                END DO
2189                DO ji = nlci/2, nlci-1
2190                   iju=iloc-ji+1
2191                   b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2192                END DO
2193             END DO
2194#endif
2195
2196          CASE ( 'V' )
2197#if defined key_z_first
2198             DO ji = 2, nlci
2199                DO jk = 1, jpk
2200#else
2201             DO jk = 1, jpk
2202                DO ji = 2, nlci
2203#endif
2204                   ijt=iloc-ji+2
2205                   b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-2,jk)
2206                   b3(ji,nlcj  ,jk) = psgn * b3(ijt,nlcj-3,jk)
2207                END DO
2208             END DO
2209
2210          CASE ( 'F', 'G' )
2211#if defined key_z_first
2212             DO ji = 1, nlci-1
2213                DO jk = 1, jpk
2214#else
2215             DO jk = 1, jpk
2216                DO ji = 1, nlci-1
2217#endif
2218                   iju=iloc-ji+1
2219                   b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-2,jk)
2220                   b3(ji,nlcj  ,jk) = psgn * b3(iju,nlcj-3,jk)
2221                END DO
2222             END DO
2223
2224          END SELECT
2225
2226       CASE ( 5 , 6 ) ! F pivot
2227          iloc=jpiglo-2*(nimpp-1)
2228
2229          SELECT CASE ( cd_type )
2230
2231          CASE ( 'T' , 'S', 'W' )
2232#if defined key_z_first
2233             DO ji = 1, nlci
2234                DO jk = 1, jpk
2235#else
2236             DO jk = 1, jpk
2237                DO ji = 1, nlci
2238#endif
2239                   ijt=iloc-ji+1
2240                   b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-1,jk)
2241                END DO
2242             END DO
2243
2244          CASE ( 'U' )
2245#if defined key_z_first
2246             DO ji = 1, nlci-1
2247                DO jk = 1, jpk
2248#else
2249             DO jk = 1, jpk
2250                DO ji = 1, nlci-1
2251#endif
2252                   iju=iloc-ji
2253                   b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-1,jk)
2254                END DO
2255             END DO
2256
2257          CASE ( 'V' )
2258#if defined key_z_first
2259             DO ji = 1, nlci
2260                DO jk = 1, jpk
2261                   ijt=iloc-ji+1
2262                   b3(ji,nlcj  ,jk) = psgn * b3(ijt,nlcj-2,jk)
2263                END DO
2264             END DO
2265             DO ji = nlci/2+1, nlci
2266                DO jk = 1, jpk
2267                   ijt=iloc-ji+1
2268                   b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2269                END DO
2270             END DO
2271#else
2272             DO jk = 1, jpk
2273                DO ji = 1, nlci
2274                   ijt=iloc-ji+1
2275                   b3(ji,nlcj  ,jk) = psgn * b3(ijt,nlcj-2,jk)
2276                END DO
2277                DO ji = nlci/2+1, nlci
2278                   ijt=iloc-ji+1
2279                   b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2280                END DO
2281             END DO
2282#endif
2283
2284          CASE ( 'F', 'G' )
2285#if defined key_z_first
2286             DO ji = 1, nlci-1
2287                DO jk = 1, jpk
2288                   iju=iloc-ji
2289                   b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2290                END DO
2291             END DO
2292             DO ji = nlci/2+1, nlci-1
2293                DO jk = 1, jpk
2294                   iju=iloc-ji
2295                   b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2296                END DO
2297             END DO
2298#else
2299             DO jk = 1, jpk
2300                DO ji = 1, nlci-1
2301                   iju=iloc-ji
2302                   b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2303                END DO
2304                DO ji = nlci/2+1, nlci-1
2305                   iju=iloc-ji
2306                   b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2307                END DO
2308             END DO
2309#endif
2310          END SELECT  ! cd_type
2311
2312       END SELECT     !  npolj
2313
2314    CASE DEFAULT ! more than 1 proc along I
2315       IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs.
2316
2317    END SELECT ! jpni
2318
2319  END SUBROUTINE apply_north_fold3
2320
2321  !=========================================================================
2322 
2323  SUBROUTINE apply_north_fold3i(ib3, isgn, cd_type)
2324    USE par_oce, ONLY: wp, jpni, jpk
2325    USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
2326    USE lib_mpp, ONLY: ctl_stop
2327    IMPLICIT none
2328!FTRANS ib3 :I :I :z
2329    INTEGER, INTENT(inout), DIMENSION(1:, 1:, :) :: ib3
2330    INTEGER,                          INTENT(in) :: isgn
2331    CHARACTER (LEN=1),                INTENT(in) :: cd_type
2332    ! Local variables
2333    INTEGER  :: ji, jk, ijt, iju, iloc
2334
2335    ! 4.1 treatment without exchange (jpni odd)
2336    !     T-point pivot 
2337
2338    SELECT CASE ( jpni )
2339
2340    CASE ( 1 )  ! only one proc along I, no mpp exchange
2341
2342       SELECT CASE ( npolj )
2343
2344       CASE ( 3 , 4 )    ! T pivot
2345          iloc = jpiglo - 2 * ( nimpp - 1 )
2346
2347          SELECT CASE ( cd_type )
2348
2349          CASE ( 'T' , 'S', 'W' )
2350#if defined key_z_first
2351             DO ji = 2, nlci
2352                DO jk = 1, jpk
2353                   ijt=iloc-ji+2
2354                   ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
2355                END DO
2356             END DO
2357             DO ji = nlci/2+1, nlci
2358                DO jk = 1, jpk
2359                   ijt=iloc-ji+2
2360                   ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2361                END DO
2362             END DO
2363#else
2364             DO jk = 1, jpk
2365                DO ji = 2, nlci
2366                   ijt=iloc-ji+2
2367                   ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
2368                END DO
2369                DO ji = nlci/2+1, nlci
2370                   ijt=iloc-ji+2
2371                   ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2372                END DO
2373             END DO
2374#endif
2375
2376          CASE ( 'U' )
2377#if defined key_z_first
2378             DO ji = 1, nlci-1
2379                DO jk = 1, jpk
2380                   iju=iloc-ji+1
2381                   ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2382                END DO
2383             END DO
2384             DO ji = nlci/2, nlci-1
2385                DO jk = 1, jpk
2386                   iju=iloc-ji+1
2387                   ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2388                END DO
2389             END DO
2390#else
2391             DO jk = 1, jpk
2392                DO ji = 1, nlci-1
2393                   iju=iloc-ji+1
2394                   ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2395                END DO
2396                DO ji = nlci/2, nlci-1
2397                   iju=iloc-ji+1
2398                   ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2399                END DO
2400             END DO
2401#endif
2402
2403          CASE ( 'V' )
2404#if defined key_z_first
2405             DO ji = 2, nlci
2406                DO jk = 1, jpk
2407#else
2408             DO jk = 1, jpk
2409                DO ji = 2, nlci
2410#endif
2411                   ijt=iloc-ji+2
2412                   ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-2,jk)
2413                   ib3(ji,nlcj  ,jk) = isgn * ib3(ijt,nlcj-3,jk)
2414                END DO
2415             END DO
2416
2417          CASE ( 'F', 'G' )
2418#if defined key_z_first
2419             DO ji = 1, nlci-1
2420                DO jk = 1, jpk
2421#else
2422             DO jk = 1, jpk
2423                DO ji = 1, nlci-1
2424#endif
2425                   iju=iloc-ji+1
2426                   ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-2,jk)
2427                   ib3(ji,nlcj  ,jk) = isgn * ib3(iju,nlcj-3,jk)
2428                END DO
2429             END DO
2430
2431          END SELECT
2432
2433       CASE ( 5 , 6 ) ! F pivot
2434          iloc=jpiglo-2*(nimpp-1)
2435
2436          SELECT CASE ( cd_type )
2437
2438          CASE ( 'T' , 'S', 'W' )
2439#if defined key_z_first
2440             DO ji = 1, nlci
2441                DO jk = 1, jpk
2442#else
2443             DO jk = 1, jpk
2444                DO ji = 1, nlci
2445#endif
2446                   ijt=iloc-ji+1
2447                   ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-1,jk)
2448                END DO
2449             END DO
2450
2451          CASE ( 'U' )
2452#if defined key_z_first
2453             DO ji = 1, nlci-1
2454                DO jk = 1, jpk
2455#else
2456             DO jk = 1, jpk
2457                DO ji = 1, nlci-1
2458#endif
2459                   iju=iloc-ji
2460                   ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-1,jk)
2461                END DO
2462             END DO
2463
2464          CASE ( 'V' )
2465#if defined key_z_first
2466             DO ji = 1, nlci
2467                DO jk = 1, jpk
2468                   ijt=iloc-ji+1
2469                   ib3(ji,nlcj  ,jk) = isgn * ib3(ijt,nlcj-2,jk)
2470                END DO
2471             END DO
2472             DO ji = nlci/2+1, nlci
2473                DO jk = 1, jpk
2474                   ijt=iloc-ji+1
2475                   ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2476                END DO
2477             END DO
2478#else
2479             DO jk = 1, jpk
2480                DO ji = 1, nlci
2481                   ijt=iloc-ji+1
2482                   ib3(ji,nlcj  ,jk) = isgn * ib3(ijt,nlcj-2,jk)
2483                END DO
2484                DO ji = nlci/2+1, nlci
2485                   ijt=iloc-ji+1
2486                   ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2487                END DO
2488             END DO
2489#endif
2490
2491          CASE ( 'F', 'G' )
2492#if defined key_z_first
2493             DO ji = 1, nlci-1
2494                DO jk = 1, jpk
2495                   iju=iloc-ji
2496                   ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2497                END DO
2498             END DO
2499             DO ji = nlci/2+1, nlci-1
2500                DO jk = 1, jpk
2501                   iju=iloc-ji
2502                   ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2503                END DO
2504             END DO
2505#else
2506             DO jk = 1, jpk
2507                DO ji = 1, nlci-1
2508                   iju=iloc-ji
2509                   ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2510                END DO
2511                DO ji = nlci/2+1, nlci-1
2512                   iju=iloc-ji
2513                   ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2514                END DO
2515             END DO
2516#endif
2517
2518          END SELECT  ! cd_type
2519
2520       END SELECT     !  npolj
2521
2522    CASE DEFAULT ! more than 1 proc along I
2523       IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs.
2524
2525    END SELECT ! jpni
2526
2527  END SUBROUTINE apply_north_fold3i
2528
2529  !================================================================
2530
2531  SUBROUTINE add_exch(iwidth, grid, dirn1, &
2532                      dirn2, dirn3, dirn4, &
2533                      r2d, r3d, i2d, i3d, isgn, lfill)
2534    USE lib_mpp, ONLY: ctl_stop
2535    IMPLICIT none
2536    ! Arguments
2537    INTEGER :: iwidth, dirn1, dirn2, dirn3, dirn4
2538    CHARACTER (LEN=1) :: grid
2539    REAL(wp), DIMENSION(:,:),   TARGET, OPTIONAL :: r2d
2540    REAL(wp), DIMENSION(:,:,:), TARGET, OPTIONAL :: r3d
2541    INTEGER,  DIMENSION(:,:),   TARGET, OPTIONAL :: i2d
2542    INTEGER,  DIMENSION(:,:,:), TARGET, OPTIONAL :: i3d
2543    INTEGER, OPTIONAL :: isgn
2544    LOGICAL, OPTIONAL :: lfill
2545    ! Local vars
2546    !!--------------------------------------------------------------------
2547
2548#if ! defined key_mpp_rkpart
2549    RETURN
2550#endif
2551
2552    IF(nextFreeExchItem > maxExchItems)THEN
2553       CALL ctl_stop('STOP','ARPDBG: implement reallocate in add_exch')
2554       RETURN
2555    END IF
2556
2557    exch_list(nextFreeExchItem)%halo_width = iwidth
2558
2559    exch_list(nextFreeExchItem)%dirn(1) = dirn1
2560    exch_list(nextFreeExchItem)%dirn(2) = dirn2
2561    exch_list(nextFreeExchItem)%dirn(3) = dirn3
2562    exch_list(nextFreeExchItem)%dirn(4) = dirn4
2563
2564    exch_list(nextFreeExchItem)%grid    = grid
2565
2566    IF(PRESENT(isgn))THEN
2567       exch_list(nextFreeExchItem)%isgn = isgn
2568    ELSE
2569       exch_list(nextFreeExchItem)%isgn = 1
2570    END IF
2571
2572    NULLIFY( exch_list(nextFreeExchItem)%r2dptr, &
2573             exch_list(nextFreeExchItem)%r3dptr, &
2574             exch_list(nextFreeExchItem)%i2dptr, &
2575             exch_list(nextFreeExchItem)%i3dptr  )
2576
2577    IF(PRESENT(r2d))THEN
2578       exch_list(nextFreeExchItem)%r2dptr => r2d
2579    ELSE IF(PRESENT(r3d))THEN
2580       exch_list(nextFreeExchItem)%r3dptr => r3d
2581    ELSE IF(PRESENT(i2d))THEN
2582       exch_list(nextFreeExchItem)%i2dptr => i2d
2583    ELSE IF(PRESENT(i3d))THEN
2584       exch_list(nextFreeExchItem)%i3dptr => i3d
2585    ELSE
2586       ! This section is both for error checking and allows me to be lazy in the
2587       ! testing code - I don't have to check which arrays I've been passed
2588       ! before I call this routine.
2589       WRITE (*,*) 'WARNING: add_exch called without a ptr to an array - will be ignored'
2590       RETURN
2591    END IF
2592
2593    IF(PRESENT(lfill))THEN
2594       exch_list(nextFreeExchItem)%lfill = lfill
2595    ELSE
2596       exch_list(nextFreeExchItem)%lfill = .false.
2597    END IF
2598
2599    nextFreeExchItem = nextFreeExchItem + 1
2600
2601  END SUBROUTINE add_exch
2602
2603  !================================================================
2604
2605  SUBROUTINE wipe_exch(item)
2606    IMPLICIT none
2607    ! Arguments
2608    TYPE (exch_item), INTENT(inout) :: item
2609
2610    NULLIFY(item%i2dptr, item%r2dptr, item%i3dptr, item%r3dptr)
2611    item%isgn = 1
2612   
2613   END SUBROUTINE wipe_exch
2614
2615   !================================================================
2616
2617   SUBROUTINE bound_exch2 (b, nhalo, nhexch,           &
2618                           comm1, comm2, comm3, comm4, &
2619                           cd_type, lfill, pval, isgn, lzero )
2620      !!----------------------------------------------------------------------
2621      !!----------------------------------------------------------------------
2622      USE par_oce, ONLY : wp
2623      IMPLICIT none
2624      REAL(wp), INTENT(inout), DIMENSION(:,:)    :: b
2625      INTEGER,           INTENT(in) :: nhalo,nhexch
2626      INTEGER,           INTENT(in) :: comm1, comm2, comm3, comm4
2627      CHARACTER (LEN=1), INTENT(in) :: cd_type
2628      LOGICAL, OPTIONAL, INTENT(in) :: lfill
2629      INTEGER, OPTIONAL, INTENT(in) :: isgn
2630      LOGICAL, OPTIONAL, INTENT(in) :: lzero
2631      REAL(wp),OPTIONAL, INTENT(in) :: pval
2632
2633      CALL bound_exch_generic( b2=b,nhalo=nhalo,nhexch=nhexch, &
2634              comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2635              cd_type=cd_type, lfill=lfill, pval=pval,         &
2636              isgn=isgn, lzero=lzero )
2637      RETURN
2638   END SUBROUTINE bound_exch2
2639
2640
2641   SUBROUTINE bound_exch2i (b, nhalo, nhexch, comm1, comm2, comm3, comm4, &
2642                            cd_type, lfill, pval, isgn, lzero )
2643      !!----------------------------------------------------------------------
2644      !!----------------------------------------------------------------------
2645      USE par_oce, ONLY: wp
2646      IMPLICIT none
2647      INTEGER, INTENT(inout), DIMENSION(:,:) :: b
2648      INTEGER,           INTENT(in) :: nhalo,nhexch
2649      INTEGER,           INTENT(in) :: comm1, comm2, comm3, comm4
2650      CHARACTER (LEN=1), INTENT(in) :: cd_type
2651      LOGICAL, OPTIONAL, INTENT(in) :: lfill
2652      INTEGER, OPTIONAL, INTENT(in) :: isgn
2653      LOGICAL, OPTIONAL, INTENT(in) :: lzero
2654      REAL(wp),OPTIONAL, INTENT(in) :: pval
2655
2656      CALL bound_exch_generic (ib2=b,nhalo=nhalo,nhexch=nhexch,           &
2657                         comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2658                         cd_type=cd_type, lfill=lfill, pval=pval,         &
2659                         isgn=isgn, lzero=lzero )
2660      RETURN
2661   END SUBROUTINE bound_exch2i
2662
2663
2664   SUBROUTINE bound_exch3 (b, nhalo, nhexch, comm1, comm2, comm3, &
2665                          comm4, cd_type, lfill, pval, isgn, lzero)
2666      !!----------------------------------------------------------------------
2667      !!----------------------------------------------------------------------
2668      USE par_oce, ONLY: wp
2669      IMPLICIT none
2670      REAL(wp), INTENT(inout), DIMENSION(:,:,:) :: b
2671      INTEGER,           INTENT(in) :: nhalo,nhexch
2672      INTEGER,           INTENT(in) :: comm1, comm2, comm3, comm4
2673      CHARACTER (LEN=1), INTENT(in) :: cd_type
2674      LOGICAL, OPTIONAL, INTENT(in) :: lfill
2675      INTEGER, OPTIONAL, INTENT(in) :: isgn
2676      LOGICAL, OPTIONAL, INTENT(in) :: lzero
2677      REAL(wp),OPTIONAL, INTENT(in) :: pval
2678
2679      CALL bound_exch_generic ( b3=b,nhalo=nhalo,nhexch=nhexch,&
2680              comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2681              cd_type=cd_type, lfill=lfill, pval=pval,         &
2682              isgn=isgn, lzero=lzero )
2683      RETURN
2684   END SUBROUTINE bound_exch3
2685
2686
2687   SUBROUTINE bound_exch3i (b, nhalo, nhexch, comm1, comm2, comm3, &
2688                           comm4, cd_type, lfill, pval, isgn, lzero)
2689      !!----------------------------------------------------------------------
2690      !!----------------------------------------------------------------------
2691      IMPLICIT none
2692      INTEGER, INTENT(inout), DIMENSION(:,:,:) :: b
2693      INTEGER,           INTENT(in) :: nhalo,nhexch
2694      INTEGER,           INTENT(in) :: comm1, comm2, comm3, comm4
2695      CHARACTER (LEN=1), INTENT(in) :: cd_type
2696      LOGICAL, OPTIONAL, INTENT(in) :: lfill
2697      INTEGER, OPTIONAL, INTENT(in) :: isgn
2698      LOGICAL, OPTIONAL, INTENT(in) :: lzero
2699      REAL(wp),OPTIONAL, INTENT(in) :: pval
2700
2701      CALL bound_exch_generic ( ib3=b,nhalo=nhalo,nhexch=nhexch, &
2702                comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2703                cd_type=cd_type, lfill=lfill, pval=pval,         &
2704                isgn=isgn, lzero=lzero )
2705
2706   END SUBROUTINE bound_exch3i
2707
2708
2709   SUBROUTINE lbc_exch2( pt2d, cd_type, psgn, cd_mpp, pval, lzero )
2710      USE par_oce, ONLY: wp, jpreci
2711      USE lib_mpp, ONLY : ctl_stop
2712      IMPLICIT none
2713      !!----------------------------------------------------------------------
2714      !!                  ***  routine mpp_lnk_2d  ***
2715      !!                 
2716      !! ** Purpose :   Message passing management for 2d array
2717      !!
2718      !! ** Method  :   Use bound_exch_generic to update halos on neighbouring
2719      !!                processes.
2720      !!
2721      !!----------------------------------------------------------------------
2722      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
2723      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2724      !                                                         ! = T , U , V , F , W and I points
2725      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2726      !                                                         ! =  1. , the sign is kept
2727      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
2728      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
2729      LOGICAL,          OPTIONAL  , INTENT(in   ) ::   lzero    ! Whether to zero halos on closed boundaries
2730
2731       ! Locals
2732      LOGICAL :: lfill
2733
2734      lfill = .FALSE.
2735      IF(PRESENT(cd_mpp))THEN
2736         lfill = .TRUE.
2737      END IF
2738
2739      CALL bound_exch_generic( b2=pt2d,nhalo=jpreci,nhexch=jpreci, &
2740            comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
2741            cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), &
2742            lzero=lzero )
2743
2744   END SUBROUTINE lbc_exch2
2745
2746
2747   SUBROUTINE lbc_exch3( ptab3d, cd_type, psgn, cd_mpp, pval, lzero )
2748      USE par_oce, ONLY: wp, jpreci
2749      USE lib_mpp, ONLY : ctl_stop
2750      IMPLICIT none
2751      !!----------------------------------------------------------------------
2752      !!----------------------------------------------------------------------
2753!FTRANS ptab3d :I :I :z
2754      REAL(wp),                         INTENT(inout) ::   ptab3d(jpi,jpj,jpk)
2755      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2756      !                                                             ! = T , U , V , F , W points
2757      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2758      !                                                             ! =  1. , the sign is kept
2759      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
2760      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
2761      LOGICAL,          OPTIONAL      , INTENT(in   ) ::   lzero    ! Whether to zero halos on closed boundaries
2762      ! Locals
2763      LOGICAL :: lfill
2764
2765      lfill = .FALSE.
2766      IF(PRESENT(cd_mpp))THEN
2767         lfill = .TRUE.
2768      END IF
2769
2770      CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci, &
2771             comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus,       &
2772             cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), &
2773             lzero=lzero )
2774
2775   END SUBROUTINE lbc_exch3
2776
2777  ! ****************************************************************************
2778
2779  SUBROUTINE exchs_generic_list (list, nfields)
2780
2781    ! **************************************************************************
2782    ! Send boundary data elements to adjacent sub-domains.
2783    !
2784    ! handle                 int    output      Exchange handle.
2785    ! comm1                  int    input       Send in direction comm1.
2786    ! comm2                  int    input       Send in direction comm2.
2787    ! comm3                  int    input       Send in direction comm3.
2788    ! comm4                  int    input       Send in direction comm4.
2789    ! cd_type                char   input       Nature of array grid-points
2790    !                                           = T , U , V , F , W points
2791    !                                           = S : T-point, north fold treatment?
2792    !                                           = G : F-point, north fold treatment?
2793    ! lfill                  logical input      Whether to simply fill
2794    !                                           overlap region or apply b.c.'s
2795    !
2796    ! Mike Ashworth, CCLRC, March 2005.
2797    ! Andrew Porter, STFC,  January 2008
2798    ! **************************************************************************
2799    USE par_oce,     ONLY: wp, jpreci, jprecj, jpni
2800    USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus,       &
2801                           IminusJminus, IplusJminus, IminusJplus,  &
2802                           nsend, nxsend, nysend, nxsendp,nysendp,nzsendp, &
2803                           nsendp, &
2804                           destination,dirsend, dirrecv,                  &
2805                           isrcsendp,jsrcsendp, idesrecvp, jdesrecvp,     &
2806                           nrecv,  &
2807                           nxrecvp,nyrecvp,nzrecvp, nrecvp, nrecvp2d,  &
2808                           source, iesub, jesub,  &
2809                           MaxCommDir, MaxComm, cyclic_bc,      &
2810                           nrecvp, npatchsend, npatchrecv
2811    USE lib_mpp,     ONLY: ctl_stop
2812#if defined key_mpp_mpi
2813    USE lib_mpp,     ONLY: mpi_comm_opa
2814#endif
2815#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
2816    USE dom_oce,     ONLY: narea
2817#endif
2818    IMPLICIT none
2819
2820    ! Subroutine arguments.
2821    TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
2822    INTEGER,                           INTENT(in) :: nfields 
2823
2824    ! Local variables.
2825
2826    LOGICAL :: enabled(0:MaxCommDir, maxExchItems)
2827    INTEGER :: ides, ierr, irecv, isend,        &
2828               isrc, jdes, jsrc, tag, tag_orig, &
2829               ibeg, iend, jbeg, jend
2830    INTEGER :: i, j, k, ic, ifield, ipatch ! Loop counters
2831    ! No. of array elements packed
2832    INTEGER :: npacked
2833    INTEGER :: handle
2834#if defined key_mpp_mpi
2835    INTEGER :: status(MPI_status_size)
2836    INTEGER :: astatus(MPI_status_size,MaxComm)
2837#endif
2838    INTEGER :: r2dcount, r3dcount, i2dcount, i3dcount
2839    ! Indices into int and real copy buffers
2840    INTEGER :: istart, rstart 
2841    ! Max no. of points to send/recv (for alloc'ing buffers)
2842    INTEGER :: maxrecvpts, maxsendpts
2843    LOGICAL, SAVE :: first_time = .TRUE.
2844    LOGICAL :: have_real_field, have_int_field
2845    ! Required size of buffer for current send
2846    INTEGER :: newSize
2847    ! The current size (in array elements) of the send buffer
2848    INTEGER, SAVE :: sendIBuffSize = 0
2849    INTEGER, SAVE :: sendBuffSize  = 0
2850#if defined key_z_first
2851    INTEGER, PARAMETER :: index_z = 1
2852#else
2853    INTEGER, PARAMETER :: index_z = 3
2854#endif
2855    !!--------------------------------------------------------------------
2856
2857#if ! defined key_mpp_rkpart
2858    RETURN
2859#endif
2860
2861    !CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat)
2862
2863    ! Allocate a communications tag/handle and a flags array.
2864
2865    handle   = get_exch_handle()
2866    tag_orig = exch_tag(handle)
2867
2868    have_real_field = .FALSE.
2869    have_int_field  = .FALSE.
2870
2871    ! Set enabled flags according to the field details.
2872    DO ifield = 1, nfields, 1
2873
2874       ! Check halo width is in range.
2875       IF ( list(ifield)%halo_width.GT.jpreci ) THEN
2876          CALL ctl_stop('STOP', &
2877                        'exchs_generic_list: halo width greater than maximum')
2878          RETURN
2879       ENDIF
2880
2881       enabled(Iplus, ifield ) = .FALSE.
2882       enabled(Jplus, ifield ) = .FALSE.
2883       enabled(Iminus, ifield) = .FALSE.
2884       enabled(Jminus, ifield) = .FALSE.
2885       enabled(list(ifield)%dirn(1), ifield) = list(ifield)%dirn(1).GT.0
2886       enabled(list(ifield)%dirn(2), ifield) = list(ifield)%dirn(2).GT.0
2887       enabled(list(ifield)%dirn(3), ifield) = list(ifield)%dirn(3).GT.0
2888       enabled(list(ifield)%dirn(4), ifield) = list(ifield)%dirn(4).GT.0
2889
2890       ! Set diagonal communications according to the non-diagonal flags.
2891
2892       enabled(IplusJplus,  ifield ) = enabled(Iplus, ifield  ).AND.enabled(Jplus, ifield  )
2893       enabled(IminusJminus,ifield ) = enabled(Iminus, ifield ).AND.enabled(Jminus, ifield )
2894       enabled(IplusJminus, ifield ) = enabled(Iplus, ifield  ).AND.enabled(Jminus, ifield )
2895       enabled(IminusJplus, ifield ) = enabled(Iminus, ifield ).AND.enabled(Jplus, ifield  )
2896
2897       have_real_field = have_real_field .OR.                  & 
2898                         ( ASSOCIATED(list(ifield)%r2dptr) .OR. &
2899                           ASSOCIATED(list(ifield)%r3dptr) )
2900
2901       have_int_field = have_int_field .OR.                    &
2902                         ( ASSOCIATED(list(ifield)%i2dptr) .OR. &
2903                           ASSOCIATED(list(ifield)%i3dptr) )
2904
2905    END DO ! Loop over fields
2906
2907    ! Main communications loop.
2908#if defined key_mpp_mpi
2909
2910    ierr = 0
2911    maxrecvpts = MAXVAL(nrecvp(1:nrecv,1))
2912    maxsendpts = MAXVAL(nsendp(1:nsend,1))
2913    !WRITE(*,"('maxrecvpts = ',I4,' maxsendpts = ',I4)") maxrecvpts, maxsendpts
2914
2915    IF( have_real_field )THEN
2916
2917       ALLOCATE(recvBuff(maxrecvpts*nfields,nrecv),stat=ierr)
2918       !WRITE(*,"('Allocated ',I7,' reals for recv buff')") &
2919       !                                 jpkdta*maxrecvpts*nfields
2920!!$       IF(.NOT. ALLOCATED(sendBuff))THEN
2921!!$          ! Only allocate the sendBuff once
2922!!$          ALLOCATE(recvBuff(jpkdta*maxrecvpts*nfields,nrecv), &
2923!!$                   sendBuff(jpkdta*maxsendpts*nfields,nsend),stat=ierr)
2924!!$          WRITE(*,"('Allocated ',I7,' reals for recv buff')") jpkdta*maxrecvpts*nfields
2925!!$          WRITE(*,"('Allocated ',I7,' reals for send buff')") jpkdta*maxsendpts*nfields
2926!!$          WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)"), nfields, jpkdta
2927!!$       ELSE
2928!!$          ALLOCATE(recvBuff(jpkdta*maxrecvpts*nfields,nrecv),stat=ierr)
2929!!$       END IF
2930    END IF
2931
2932    IF( have_int_field .AND. (ierr == 0) )THEN
2933
2934       ALLOCATE(recvIBuff(maxrecvpts*nfields,nrecv),stat=ierr)
2935       !WRITE(*,"('Allocated ',I7,' ints for recv buff')") &
2936       !                                 jpkdta*maxrecvpts*nfields
2937
2938!!$       IF(.NOT. ALLOCATED(sendIBuff))THEN
2939!!$          ALLOCATE(recvIBuff(jpkdta*maxrecvpts*nfields,nrecv), &
2940!!$                   sendIBuff(jpkdta*maxsendpts*nfields,nsend),stat=ierr)
2941!!$       ELSE
2942!!$          ALLOCATE(recvIBuff(jpkdta*maxrecvpts*nfields,nrecv),stat=ierr)
2943!!$       END IF
2944    END IF
2945
2946    IF (ierr .ne. 0) THEN
2947       WRITE(*,*) 'ARPDBG: failed to allocate recv buf'
2948       CALL ctl_stop('STOP','exchs_generic_list: unable to allocate recv buffs')
2949    END IF
2950
2951    ! Initiate receives in case posting them first improves
2952    ! performance.
2953
2954    exch_flags(handle,1:nrecv,indexr) = MPI_REQUEST_NULL
2955
2956    DO irecv=1, nrecv, 1
2957
2958       r2dcount = 0
2959       r3dcount = 0
2960       i2dcount = 0
2961       i3dcount = 0
2962
2963       IF( source(irecv).GE.0 .AND. &
2964           ( (nrecvp(irecv,1) > 0) .OR. (nrecvp2d(irecv,1) > 0) ) ) THEN
2965
2966          ! This loop is to allow for different fields to have different
2967          ! direction requirements (possibly unecessary)
2968          DO ifield=1,nfields,1
2969
2970             IF ( enabled(dirrecv(irecv), ifield) ) THEN
2971                IF( ASSOCIATED(list(ifield)%r2dptr) )THEN
2972                   r2dcount = r2dcount + nrecvp2d(irecv,1)
2973                ELSE IF( ASSOCIATED(list(ifield)%i2dptr) )THEN
2974                   i2dcount = i2dcount + nrecvp2d(irecv,1)
2975                ELSE IF( ASSOCIATED(list(ifield)%r3dptr) )THEN
2976                   ! Allow for varying size of third dimension
2977                   r3dcount = r3dcount + nrecvp(irecv,1)
2978                ELSE IF( ASSOCIATED(list(ifield)%i3dptr) )THEN
2979                   ! Allow for varying size of third dimension
2980                   i3dcount = i3dcount + nrecvp(irecv,1)
2981                END IF
2982             END IF
2983
2984          END DO
2985
2986          tag = tag_orig + dirrecv(irecv)
2987
2988#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
2989          WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") &
2990                                    narea-1,tag ,source(irecv), nrecvp(irecv,1)
2991#endif
2992
2993          IF ( r2dcount > 0 .OR. r3dcount > 0 ) THEN
2994             CALL MPI_irecv (recvBuff(1,irecv),(r2dcount+r3dcount),     &
2995                             MPI_DOUBLE_PRECISION, source(irecv), tag, mpi_comm_opa, &
2996                             exch_flags(handle,irecv,indexr), ierr)
2997          END IF
2998          IF ( i2dcount > 0 .OR. i3dcount > 0 ) THEN
2999             CALL MPI_irecv (recvIBuff(1,irecv),(i2dcount+i3dcount),       &
3000                             MPI_INTEGER, source(irecv),tag, mpi_comm_opa, &
3001                             exch_flags(handle,irecv,indexr),ierr)
3002          END IF
3003
3004!!$#if defined DEBUG_COMMS
3005!!$          WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' opp dirn = ',I1,' src = ',I3,' tag = ',I4,' flag = ',I3)") &
3006!!$                  narea-1,handle,dirrecv(irecv), &
3007!!$                  opp_dirn(dirrecv(irecv)),source(irecv), &
3008!!$                  tag, exch_flags(handle,irecv,indexr)
3009!!$#endif
3010
3011       END IF
3012
3013    ENDDO ! Loop over receives
3014
3015
3016    ! Check that all sends from previous call have completed before
3017    ! we continue and modify the send buffers
3018    IF (.not. first_time) THEN 
3019     
3020       CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr)
3021       IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3022
3023    ELSE
3024        first_time = .FALSE.
3025    END IF ! .not. first_time
3026
3027    ! Now allocate/reallocate SEND buffers
3028
3029    ierr = 0
3030    newSize = maxsendpts*nfields
3031    IF( have_real_field .AND. newSize > sendBuffSize)THEN
3032       sendBuffSize=newSize
3033       IF(ALLOCATED(sendBuff))DEALLOCATE(sendBuff)
3034       ALLOCATE(sendBuff(sendBuffSize,nsend),stat=ierr)
3035
3036       !WRITE(*,"('Allocated ',I7,' reals for send buff')") sendBuffSize
3037       !WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)") nfields, jpkdta
3038    END IF
3039
3040    IF( have_int_field .AND. newSize > sendIBuffSize)THEN
3041       sendIBuffSize = newSize
3042       IF(ALLOCATED(sendIBuff))DEALLOCATE(sendIBuff)
3043       ALLOCATE(sendIBuff(sendIBuffSize,nsend),stat=ierr)
3044    END IF
3045
3046    IF (ierr .ne. 0) THEN
3047       CALL ctl_stop('STOP','exchs_generic_list: unable to allocate send buff')
3048    END IF
3049
3050    ! Send all messages in the communications list.
3051
3052    exch_flags(handle,1:nsend,indexs) = MPI_REQUEST_NULL
3053
3054    DO isend=1, nsend, 1
3055
3056       rstart = 1
3057       istart = 1
3058       r2dcount = 0
3059       r3dcount = 0
3060       i2dcount = 0
3061       i3dcount = 0
3062
3063       IF ( destination(isend).GE.0 .AND. nxsend(isend).GT.0 ) THEN
3064
3065          ! Loop over the fields for which we are going to exchange halos
3066          ! and pack the data to send into a buffer
3067          DO ifield=1, nfields, 1
3068
3069             IF( enabled(dirsend(isend), ifield) )THEN
3070
3071                tag = tag_orig + dirsend(isend)
3072
3073!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
3074!!$                WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & 
3075!!$               narea-1, handle, tag, destination(isend),nsendp(isend,1)*XXX,dirsend(isend)
3076!!$#endif
3077
3078                ! Copy the data into the send buffer and send it. The
3079                ! performance of this copy matters!
3080
3081                IF ( ASSOCIATED(list(ifield)%r2dptr) )THEN
3082
3083                   ic = rstart - 1
3084
3085                   pack_patches2r: DO ipatch=1, npatchsend(isend,1), 1
3086
3087                      ibeg = isrcsendp(ipatch,isend,1)
3088                      iend = ibeg + nxsendp(ipatch,isend,1)-1
3089                      jbeg = jsrcsendp(ipatch,isend,1)
3090                      jend = jbeg + nysendp(ipatch,isend,1)-1
3091
3092                      DO j=jbeg, jend, 1
3093                         DO i=ibeg, iend, 1
3094                            ic = ic + 1
3095                            sendBuff(ic, isend) = list(ifield)%r2dptr(i,j)
3096                         END DO
3097                      END DO
3098
3099                      npacked =  nxsendp(ipatch,isend,1) * &
3100                                 nysendp(ipatch,isend,1)
3101                      rstart   = rstart   + npacked
3102                      r2dcount = r2dcount + npacked
3103
3104                   END DO pack_patches2r
3105
3106                ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3107
3108                   ic = istart - 1
3109
3110                   pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1
3111
3112                      jbeg = jsrcsendp(ipatch,isend,1)
3113                      ibeg = isrcsendp(ipatch,isend,1)
3114                      jend = jbeg + nysendp(ipatch,isend,1)-1
3115                      iend = ibeg + nxsendp(ipatch,isend,1)-1
3116
3117                      DO j=jbeg, jend, 1
3118                         DO i=ibeg, iend, 1
3119                            ic = ic + 1
3120                            sendIBuff(ic,isend) = list(ifield)%i2dptr(i,j)
3121                         END DO
3122                      END DO
3123                   
3124                      npacked =  nxsendp(ipatch,isend,1) * &
3125                                 nysendp(ipatch,isend,1)
3126                      istart   = istart + npacked
3127                      i2dcount = i2dcount + npacked
3128
3129                   END DO pack_patches2i
3130
3131                ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) )THEN
3132
3133                   ic = rstart - 1
3134
3135                   pack_patches3r: DO ipatch=1, npatchsend(isend,1), 1
3136
3137!                      WRITE(*,"('Field = ',I2,' patch = ',I2,' ic = ',I4)") &
3138!                           ifield, ipatch, ic
3139                      jbeg = jsrcsendp(ipatch,isend,1)
3140                      ibeg = isrcsendp(ipatch,isend,1)
3141                      jend = jbeg + nysendp(ipatch,isend,1)-1
3142                      iend = ibeg + nxsendp(ipatch,isend,1)-1
3143
3144#if defined key_z_first
3145                      DO j=jbeg, jend, 1
3146                         DO i=ibeg, iend, 1
3147                            !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
3148                            DO k=1, nzsendp(ipatch,isend,1), 1
3149#else
3150                      !DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
3151                      DO k=1, nzsendp(ipatch,isend,1), 1
3152                         DO j=jbeg, jend, 1
3153                            DO i=ibeg, iend, 1
3154#endif
3155                               ic = ic + 1
3156                               sendBuff(ic, isend) = list(ifield)%r3dptr(i,j,k)
3157                            END DO
3158                         END DO
3159                      END DO
3160                   
3161                      npacked =  nxsendp(ipatch,isend,1) * &
3162                                 nysendp(ipatch,isend,1) * &
3163                                 nzsendp(ipatch,isend,1)
3164                      rstart   = rstart + npacked
3165                      r3dcount = r3dcount + npacked
3166
3167                   END DO pack_patches3r
3168
3169                ELSEIF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3170
3171                   ic = istart - 1
3172
3173                   pack_patches3i: DO ipatch = 1, npatchsend(isend, 1), 1
3174
3175                      jbeg = jsrcsendp(ipatch,isend,1)
3176                      ibeg = isrcsendp(ipatch,isend,1)
3177                      jend = jbeg + nysendp(ipatch,isend,1)-1
3178                      iend = ibeg + nxsendp(ipatch,isend,1)-1
3179
3180#if defined key_z_first
3181                      DO j=jbeg, jend, 1
3182                         DO i=ibeg, iend, 1
3183                            !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
3184                            DO k=1, nzsendp(ipatch,isend,1), 1
3185#else
3186                      !DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
3187                      DO k=1, nzsendp(ipatch,isend,1), 1
3188                         DO j=jbeg, jend, 1
3189                            DO i=ibeg, iend, 1
3190#endif
3191                               ic = ic + 1
3192                               sendIBuff(ic, isend) = list(ifield)%i3dptr(i,j,k)
3193                            END DO
3194                         END DO
3195                      END DO
3196
3197                      npacked = nxsendp(ipatch,isend,1)* &
3198                                nysendp(ipatch,isend,1)* &
3199                                nzsendp(ipatch,isend,1)
3200                      istart   = istart +  npacked
3201                      i3dcount = i3dcount + npacked
3202                   END DO pack_patches3i
3203
3204                ENDIF
3205
3206#if defined DEBUG_COMMS
3207                WRITE (*,FMT="(I4,': Isend to ',I3,' has flag ',I3)") &
3208                     narea-1, destination(isend), exch_flags(handle,isend,indexs)
3209#endif
3210
3211             END IF ! Direction enabled for this field
3212
3213          END DO ! Loop over fields
3214
3215          ! Now do the send(s) for all fields
3216          IF(r2dcount > 0 .OR. r3dcount > 0 )THEN
3217             CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount), &
3218                            MPI_DOUBLE_PRECISION,                  &
3219                            destination(isend),tag,mpi_comm_opa,   &
3220                            exch_flags(handle,isend,indexs),ierr)
3221          END IF
3222          IF(i2dcount > 0 .OR. i3dcount > 0 )THEN
3223              CALL MPI_Isend(sendIBuff(1,isend),(i2dcount+i3dcount), &
3224                             MPI_INTEGER, destination(isend),tag,    &
3225                             mpi_comm_opa, exch_flags(handle,isend,indexs),&
3226                             ierr)
3227           END IF
3228
3229       ENDIF ! direction is enabled and have something to send
3230
3231    ENDDO ! Loop over sends
3232
3233#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
3234    WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3235#endif
3236
3237    ! Wait on the receives that were posted earlier
3238
3239    ! Copy just the set of flags we're interested in for passing to MPI_waitany
3240    exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3241
3242    CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3243    IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3244
3245    DO WHILE(irecv .ne. MPI_UNDEFINED)
3246
3247          istart = 1
3248          rstart = 1
3249
3250          DO ifield = 1, nfields, 1
3251
3252             IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3253
3254                ! Copy received data back into array
3255                ic = rstart - 1
3256                unpack_patches2r: DO ipatch=1, npatchrecv(irecv,1), 1
3257
3258                   jbeg = jdesrecvp(ipatch,irecv,1)
3259                   jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3260                   ibeg = idesrecvp(ipatch,irecv,1)
3261                   iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3262
3263                   DO j=jbeg, jend, 1
3264                      DO i=ibeg, iend, 1
3265   
3266                         ic = ic + 1
3267                         list(ifield)%r2dptr(i,j) = recvBuff(ic,irecv)
3268                      END DO
3269                   END DO
3270
3271                END DO unpack_patches2r
3272
3273                ! Increment starting index for next field data in buffer
3274                rstart = ic + 1 !rstart + nrecvp(irecv,1)
3275
3276             ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3277
3278                ! Copy received data back into array
3279                ic = istart - 1
3280                unpack_patches2i: DO ipatch = 1, npatchrecv(irecv,1), 1
3281
3282                   jbeg = jdesrecvp(ipatch,irecv,1)
3283                   jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3284                   ibeg = idesrecvp(ipatch,irecv,1)
3285                   iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3286
3287                   DO j=jbeg, jend, 1
3288                      DO i=ibeg, iend, 1
3289                         ic = ic + 1
3290                         list(ifield)%i2dptr(i,j) = recvIBuff(ic,irecv)
3291                      END DO
3292                   END DO
3293                END DO unpack_patches2i
3294
3295                ! Increment starting index for next field data in buffer
3296                istart = ic + 1 !istart + nrecvp(irecv,1)
3297
3298             ELSE IF (ASSOCIATED(list(ifield)%r3dptr) ) THEN
3299
3300                ic = rstart - 1
3301                unpack_patches3r: DO ipatch=1,npatchrecv(irecv,1)
3302
3303                   jbeg = jdesrecvp(ipatch,irecv,1)
3304                   jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3305                   ibeg = idesrecvp(ipatch,irecv,1)
3306                   iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3307#if defined key_z_first
3308                   DO j=jbeg, jend, 1
3309                      DO i=ibeg, iend, 1
3310                         DO k=1, nzrecvp(ipatch,irecv,1), 1
3311#else
3312                   DO k=1, nzrecvp(ipatch,irecv,1), 1
3313                      DO j=jbeg, jend, 1
3314                         DO i=ibeg, iend, 1
3315#endif
3316                            ic = ic + 1
3317                            list(ifield)%r3dptr(i,j,k) = recvBuff(ic,irecv)
3318                         END DO
3319                      END DO
3320                   END DO
3321                END DO unpack_patches3r
3322
3323                ! Increment starting index for next field data in buffer
3324                rstart = ic + 1 ! rstart + nrecvp(irecv,1) !*SIZE(list(ifield)%r3dptr,index_z)
3325
3326             ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3327
3328                ic = istart - 1
3329                unpack_patches3i: DO ipatch=1,npatchrecv(irecv,1)
3330                   
3331                   jbeg = jdesrecvp(ipatch,irecv,1)
3332                   jend = jbeg+nyrecvp(ipatch,irecv,1)-1
3333                   ibeg = idesrecvp(ipatch,irecv,1)
3334                   iend = ibeg+nxrecvp(ipatch,irecv,1)-1
3335#if defined key_z_first
3336                   DO j=jbeg, jend, 1
3337                      DO i=ibeg, iend, 1
3338                         DO k=1,nzrecvp(ipatch,irecv,1),1
3339#else
3340                   DO k=1,nzrecvp(ipatch,irecv,1),1
3341                      DO j=jbeg, jend, 1
3342                         DO i=ibeg, iend, 1
3343#endif
3344                            ic = ic + 1
3345                            list(ifield)%i3dptr(i,j,k) = recvIBuff(ic,irecv)
3346                         END DO
3347                      END DO
3348                   END DO
3349                END DO unpack_patches3i
3350
3351                ! Increment starting index for next field data in buffer
3352                istart = ic + 1 !istart + nrecvp(irecv,1) !*SIZE(list(ifield)%i3dptr,index_z)
3353
3354             END IF
3355
3356          END DO ! Loop over fields
3357
3358          ! Wait for the next received message (if any)
3359          CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3360          IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3361
3362    END DO ! while irecv != MPI_UNDEFINED
3363
3364    ! All receives done and unpacked - can deallocate the recv buffer now
3365    IF(ALLOCATED(recvBuff))DEALLOCATE(recvBuff)
3366    IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
3367
3368#endif /* key_mpp_mpi */
3369
3370    ! Periodic boundary condition using internal copy.
3371    ! This is performed after all data has been received so that we can
3372    ! also copy boundary points and avoid some diagonal communication.
3373    ! Since this is just a copy we don't worry about the 'patches' of
3374    ! wet points here.
3375
3376    ! ARPDBG - fairly certain this code is not yet correct :-(
3377
3378    IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
3379
3380       DO ifield=1,nfields,1
3381
3382          IF ( enabled(Iplus,ifield) ) THEN
3383
3384             DO j=1,jesub+list(ifield)%halo_width
3385
3386                DO i=1,list(ifield)%halo_width
3387
3388                   IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3389                      list(ifield)%r2dptr(iesub+i,j) = list(ifield)%r2dptr(i,j)
3390                   ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3391                      list(ifield)%i2dptr(iesub+i,j) = list(ifield)%i2dptr(i,j)
3392                   ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN
3393                      DO k=1,SIZE(list(ifield)%r3dptr, index_z)
3394                         list(ifield)%r3dptr(iesub+i,j,k) = list(ifield)%r3dptr(i,j,k)
3395                      ENDDO
3396                   ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3397                      DO k=1,SIZE(list(ifield)%i3dptr, index_z)
3398                         list(ifield)%i3dptr(iesub+i,j,k) = list(ifield)%i3dptr(i,j,k)
3399                      ENDDO
3400                   END IF
3401                ENDDO
3402             ENDDO
3403          END IF
3404
3405          IF ( enabled(Iminus,ifield) ) THEN
3406             !ARPDBG        DO j=1,jesub,1
3407             DO j=1,jesub+list(ifield)%halo_width
3408                DO i=1, list(ifield)%halo_width
3409                   IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3410                      !ARPDBG                 b2(i,j) = b2(iesub-i+1,j)
3411                      list(ifield)%r2dptr(i,j) = list(ifield)%r2dptr(iesub-i+1,j)
3412                   ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3413                      !ARPDBG                 ib2(i,j) = ib2(iesub-i+1,j)
3414                      list(ifield)%i2dptr(i,j) = list(ifield)%i2dptr(iesub-i+1,j)
3415                   ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN
3416
3417                      DO k=1,SIZE(list(ifield)%r3dptr,index_z),1
3418                         !ARPDBG                    b3(k,i,j) = b3(k,iesub-i+1,j)
3419                         list(ifield)%r3dptr(i,j,k) = list(ifield)%r3dptr(iesub-i+1,j,k)
3420                      ENDDO
3421                   ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3422                      DO k=1,SIZE(list(ifield)%i3dptr,index_z), 1
3423                         !ARPDBG                    ib3(k,i,j) = ib3(k,iesub-i+1,j)
3424                         list(ifield)%i3dptr(i,j,k) = list(ifield)%i3dptr(iesub-i+1,j,k)
3425                      END DO
3426                   END IF
3427                END DO
3428             END DO
3429          END IF
3430       
3431       END DO ! Loop over fields
3432    ENDIF ! cyclic_bc .AND. jpni==1
3433
3434    ! Copy just the set of flags we're interested in for passing to 
3435    ! MPI_waitall next time around 
3436    exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
3437
3438    ! Free the exchange communications handle.
3439    CALL free_exch_handle(handle)
3440
3441    !CALL prof_region_end(ARPEXCHS_LIST, iprofStat)
3442   
3443  END SUBROUTINE exchs_generic_list
3444
3445  ! *********************************************************************
3446
3447  SUBROUTINE exchs_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
3448                             handle, comm1, comm2, comm3, comm4, &
3449                             cd_type, lfill)
3450
3451    ! *******************************************************************
3452    ! Send boundary data elements to adjacent sub-domains.
3453
3454    ! b2(:,:)                real   input       2D real*8 local array.
3455    ! ib2(:,:)               int    input       2D integer local array.
3456    ! b3(:,:,:)              real   input       3D real*8 local array.
3457    ! ib3(:,:,:)             int    input       3D integer local array.
3458    ! nhalo                  int    input       Width of halo.
3459    ! nhexch                 int    input       Number of halo
3460    ! rows/cols to exchange.
3461    ! handle                 int    output      Exchange handle.
3462    ! comm1                  int    input       Send in direction comm1.
3463    ! comm2                  int    input       Send in direction comm2.
3464    ! comm3                  int    input       Send in direction comm3.
3465    ! comm4                  int    input       Send in direction comm4.
3466    ! cd_type                char   input       Nature of array grid-points
3467    !                                           = T , U , V , F , W points
3468    !                                           = S : T-point, north fold treatment?
3469    !                                           = G : F-point, north fold treatment?
3470    ! lfill                  logical input      Whether to simply fill
3471    !                                           overlap region or apply b.c.'s
3472    !
3473    ! Mike Ashworth, CCLRC, March 2005.
3474    ! Andrew Porter, STFC,  January 2008
3475    ! *******************************************************************
3476    USE par_oce,     ONLY: wp, jpreci, jprecj, jpni, jpkdta
3477    USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus,   &
3478                           IminusJminus, IplusJminus, IminusJplus,     &
3479                           nrecv, nsend, nrecvp, nsendp,               &
3480                           nrecvp2d, nsendp2d,  nxsend, nysend,        &
3481                           destination,dirsend, dirrecv,               &
3482                           isrcsend, jsrcsend, idesrecv, jdesrecv,     &
3483                           isrcsendp,jsrcsendp,idesrecvp,jdesrecvp,    &
3484                           nxrecv,source, iesub, jesub,         &
3485                           MaxCommDir, MaxComm, idessend, jdessend,    &
3486                           nxsendp, nysendp, nzsendp,                  &
3487                           nxrecvp, nyrecvp, nzrecvp,                  &
3488                           npatchsend, npatchrecv, cyclic_bc
3489    USE lib_mpp,     ONLY: ctl_stop
3490#if defined key_mpp_mpi
3491    USE lib_mpp,     ONLY: mpi_comm_opa
3492#endif
3493    USE dom_oce,     ONLY: narea
3494    USE in_out_manager, ONLY: numout
3495    IMPLICIT none
3496
3497    ! Subroutine arguments.
3498    INTEGER, INTENT(in)  :: nhalo,nhexch
3499    INTEGER, INTENT(out) :: handle
3500
3501!FTRANS b3  :I :I :z
3502!FTRANS ib3 :I :I :z
3503    REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:)   :: b2
3504    INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:)   :: ib2
3505    REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: b3
3506    INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: ib3
3507
3508    INTEGER,           INTENT(in) :: comm1, comm2, comm3, comm4
3509    CHARACTER(len=1),  INTENT(in) :: cd_type
3510    LOGICAL,           INTENT(in) :: lfill
3511
3512    ! Local variables.
3513
3514    LOGICAL :: enabled(0:MaxCommDir)
3515    INTEGER :: ierr, irecv, ircvdt, isend, isnddt, &
3516               isrc, jsrc, kdim1, &  ! ides, jdes, nxr, nyr,        &
3517               nxs, nys, tag, tag_orig
3518    INTEGER :: maxrecvpts, maxsendpts ! Max no. of grid points involved in
3519                                      ! any one halo exchange
3520    INTEGER :: i, j, k, ic, ipatch ! Loop counters
3521    INTEGER :: istart, iend, jstart, jend
3522    INTEGER :: index  ! To hold index returned from MPI_waitany
3523    INTEGER, DIMENSION(3) :: isubsizes, istarts ! isizes
3524#if defined key_mpp_mpi
3525    INTEGER :: status(MPI_status_size)
3526    INTEGER :: astatus(MPI_status_size,MaxComm)
3527#endif
3528    LOGICAL, SAVE :: first_time = .TRUE.
3529#if defined key_z_first
3530    INTEGER, PARAMETER :: index_z = 1
3531#else
3532    INTEGER, PARAMETER :: index_z = 3
3533#endif
3534    !!--------------------------------------------------------------------
3535
3536#if ! defined key_mpp_rkpart
3537    RETURN
3538#endif
3539
3540    !CALL prof_region_begin(ARPEXCHS_GENERIC, "Exchs_indiv", iprofStat)
3541    !CALL timing_start('exchs_generic')
3542
3543    ierr = 0
3544
3545    ! Check nhexch is in range.
3546
3547    IF ( nhexch.GT.jpreci ) THEN
3548       CALL ctl_stop('STOP','exchs: halo width greater than maximum')
3549    ENDIF
3550
3551    ! Allocate a communications tag/handle and a flags array.
3552
3553    handle   = get_exch_handle()
3554    tag_orig = exch_tag(handle)
3555
3556    ! Set enabled flags according to the subroutine arguments.
3557
3558    enabled(Iplus ) = .FALSE.
3559    enabled(Jplus ) = .FALSE.
3560    enabled(Iminus) = .FALSE.
3561    enabled(Jminus) = .FALSE.
3562    enabled(comm1) = comm1.GT.0
3563    enabled(comm2) = comm2.GT.0
3564    enabled(comm3) = comm3.GT.0
3565    enabled(comm4) = comm4.GT.0
3566
3567    ! Set diagonal communications according to the non-diagonal flags.
3568
3569    enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
3570    enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
3571    enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
3572    enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
3573
3574    ! Main communications loop.
3575#if defined key_mpp_mpi
3576
3577    maxrecvpts = MAXVAL(nrecvp(1:nrecv,1))
3578    maxsendpts = MAXVAL(nsendp(1:nsend,1))
3579
3580    IF(PRESENT(b2) .OR. PRESENT(b3))THEN
3581       IF(.NOT. ALLOCATED(sendBuff))THEN
3582          ! Only allocate the sendBuff once
3583          ALLOCATE(recvBuff(maxrecvpts,nrecv), &
3584                   sendBuff(maxsendpts,nsend),stat=ierr)
3585       ELSE
3586          ALLOCATE(recvBuff(maxrecvpts,nrecv),stat=ierr)
3587       END IF
3588    ELSE IF(PRESENT(ib2) .OR. PRESENT(ib3))THEN
3589       IF(.NOT. ALLOCATED(sendIBuff))THEN
3590          ALLOCATE(recvIBuff(maxrecvpts,nrecv), &
3591                   sendIBuff(maxsendpts,nsend),stat=ierr)
3592       ELSE
3593          ALLOCATE(recvIBuff(maxrecvpts,nrecv),stat=ierr)
3594       END IF
3595    END IF
3596
3597    IF (ierr .ne. 0) THEN
3598       CALL ctl_stop('STOP','exchs_generic: unable to allocate send/recvBuffs')
3599    END IF
3600
3601    ! Initiate receives in case posting them first improves
3602    ! performance.
3603
3604    DO irecv=1,nrecv
3605
3606       IF ( enabled(dirrecv(irecv)) .AND. &
3607            source(irecv).GE.0 .AND. nxrecv(irecv).GT.0 ) THEN
3608
3609          tag = tag_orig + dirrecv(irecv)
3610
3611#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
3612          WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") narea-1,tag ,source(irecv), nrecvp(irecv,1)
3613#endif
3614          ! ARPDBG - nrecvp second rank is for multiple halo widths but
3615          !          that isn't used
3616          IF ( PRESENT(b2) ) THEN
3617             CALL MPI_irecv (recvBuff(1,irecv),nrecvp2d(irecv,1), &
3618                             MPI_DOUBLE_PRECISION, source(irecv), &
3619                             tag, mpi_comm_opa,                   &
3620                             exch_flags(handle,irecv,indexr), ierr)
3621          ELSEIF ( PRESENT(ib2) ) THEN
3622             CALL MPI_irecv (recvIBuff(1,irecv),nrecvp2d(irecv,1), &
3623                             MPI_INTEGER, source(irecv),         &
3624                             tag, mpi_comm_opa,                  &
3625                             exch_flags(handle,irecv,indexr),ierr)
3626          ELSEIF ( PRESENT(b3) ) THEN
3627             CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1),   &
3628                             MPI_DOUBLE_PRECISION, source(irecv), &
3629                             tag, mpi_comm_opa,                   &
3630                             exch_flags(handle,irecv,indexr),ierr)
3631          ELSEIF ( PRESENT(ib3) ) THEN
3632             CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1), &
3633                             MPI_INTEGER, source(irecv),         &
3634                             tag, mpi_comm_opa,                  &
3635                             exch_flags(handle,irecv,indexr),ierr)
3636          ENDIF
3637          ! No point checking for MPI errors because default MPI error handler
3638          ! aborts run without returning control to calling program.
3639          !IF ( ierr.NE.0 ) THEN
3640          !   WRITE (numout,*) 'ARPDBG - irecv hit error'
3641          !   CALL flush(numout)
3642          !   CALL MPI_abort(mpi_comm_opa,1,ierr)
3643          !END IF
3644
3645#if defined DEBUG_COMMS
3646          WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' src = ',I3,' tag = ',I4,' npoints = ',I6)") &
3647                  narea-1,handle,dirrecv(irecv), &
3648                  source(irecv), tag, nrecvp(irecv,1)
3649#endif
3650
3651       ELSE
3652          exch_flags(handle,irecv,indexr) = MPI_REQUEST_NULL
3653       END IF
3654
3655    ENDDO
3656
3657    IF (.not. first_time) THEN       
3658
3659       ! Check that all sends from previous call have completed before
3660       ! we continue to modify the send buffers
3661       CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr)
3662       IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3663
3664     ELSE
3665        first_time = .FALSE.
3666    END IF ! .not. first_time
3667
3668
3669    ! Send all messages in the communications list.
3670
3671!    CALL timing_start('mpi_sends')
3672
3673    DO isend=1,nsend
3674
3675       IF ( enabled(dirsend(isend)) .AND. &
3676            destination(isend) >= 0 .AND. nxsend(isend) > 0 ) THEN
3677
3678          isrc = isrcsend(isend)
3679          jsrc = jsrcsend(isend)
3680          nxs  =   nxsend(isend)
3681          nys  =   nysend(isend)
3682
3683          tag = tag_orig + dirsend(isend)
3684
3685#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
3686          IF(PRESENT(b3))THEN
3687             WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & 
3688               narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend)
3689          ELSE IF(PRESENT(b2))THEN
3690             WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") & 
3691               narea-1, handle, tag, destination(isend),nsendp2d(isend,1),dirsend(isend)
3692          END IF
3693#endif
3694
3695          ! Copy the data into the send buffer and send it...
3696
3697          IF ( PRESENT(b2) )THEN
3698
3699!             CALL timing_start('2dr_pack')
3700             ic = 0
3701             pack_patches2r: DO ipatch=1,npatchsend(isend,1)
3702                istart = isrcsendp(ipatch,isend,1)
3703                iend   = istart+nxsendp(ipatch,isend,1)-1
3704                jstart = jsrcsendp(ipatch,isend,1)
3705                jend   = jstart+nysendp(ipatch,isend,1)-1
3706
3707                DO j=jstart, jend, 1
3708                   DO i=istart, iend, 1
3709                      ic = ic + 1
3710                      sendBuff(ic,isend) = b2(i,j)
3711                   END DO
3712                END DO
3713
3714!!$                ! For 'stupid' compiler that refuses to do a memcpy for above
3715!!$                CALL do_real8_copy( nxsendp(patch,isend,1)*nysendp(patch,isend,1), &
3716!!$                                    b2(istart,jstart),                             &
3717!!$                                    sendBuff(ic,isend) )
3718!!$                ic = ic + nxsendp(patch,isend,1)*nysendp(patch,isend,1)
3719
3720             END DO pack_patches2r
3721
3722!             CALL timing_stop('2dr_pack')
3723
3724             CALL MPI_Isend(sendBuff(1,isend),ic,MPI_DOUBLE_PRECISION, &
3725                            destination(isend),tag,mpi_comm_opa, &
3726                            exch_flags(handle,isend,indexs),ierr)
3727
3728          ELSEIF ( PRESENT(ib2) ) THEN
3729
3730             ic = 0
3731             pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1
3732                jstart = jsrcsendp(ipatch,isend,1)
3733                istart = isrcsendp(ipatch,isend,1)
3734                jend   = jstart+nysendp(ipatch,isend,1)-1
3735                iend   = istart+nxsendp(ipatch,isend,1)-1
3736
3737                DO j=jstart, jend, 1
3738                   DO i=istart, iend, 1
3739                      ic = ic + 1
3740                      sendIBuff(ic,isend) = ib2(i,j)
3741                   END DO
3742                END DO
3743             END DO pack_patches2i
3744
3745             CALL MPI_Isend(sendIBuff(1,isend),ic, MPI_INTEGER, &
3746                            destination(isend),tag,mpi_comm_opa,&
3747                            exch_flags(handle,isend,indexs),ierr)
3748
3749          ELSEIF ( PRESENT(b3) )THEN
3750
3751             ! CALL timing_start('3dr_pack')
3752             ic = 0
3753             pack_patches3r: DO ipatch=1,npatchsend(isend,1)
3754
3755                jstart = jsrcsendp(ipatch,isend,1)
3756                istart = isrcsendp(ipatch,isend,1)
3757                jend   = jstart+nysendp(ipatch,isend,1)-1
3758                iend   = istart+nxsendp(ipatch,isend,1)-1
3759#if defined key_z_first
3760                DO j=jstart, jend, 1
3761                   DO i=istart, iend, 1
3762                      DO k=1,nzsendp(ipatch,isend,1),1
3763#else
3764                DO k=1,nzsendp(ipatch,isend,1),1
3765                   DO j=jstart, jend, 1
3766                      DO i=istart, iend, 1
3767#endif
3768                         ic = ic + 1
3769                         sendBuff(ic, isend) = b3(i,j,k)
3770                      END DO
3771                   END DO
3772                END DO
3773             END DO pack_patches3r
3774
3775             ! CALL timing_stop('3dr_pack')
3776
3777             CALL MPI_Isend(sendBuff(1,isend),ic,                  &
3778                            MPI_DOUBLE_PRECISION,                  &
3779                            destination(isend), tag, mpi_comm_opa, &
3780                            exch_flags(handle,isend,indexs),ierr)
3781
3782#if defined DEBUG_COMMS
3783             WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &
3784                     narea-1, npatchsend(isend,1),ic, &
3785                     destination(isend)
3786#endif
3787
3788           ELSEIF ( PRESENT(ib3) ) THEN
3789
3790              ic = 0
3791              pack_patches3i: DO ipatch=1,npatchsend(isend,1)
3792                 jstart = jsrcsendp(ipatch,isend,1) !+nhalo
3793                 istart = isrcsendp(ipatch,isend,1) !+nhalo
3794                 jend   = jstart+nysendp(ipatch,isend,1)-1
3795                 iend   = istart+nxsendp(ipatch,isend,1)-1
3796#if defined key_z_first
3797                 DO j=jstart, jend, 1
3798                    DO i=istart, iend, 1
3799                       DO k=1,nzsendp(ipatch,isend,1),1
3800#else
3801                 DO k=1,nzsendp(ipatch,isend,1),1
3802                    DO j=jstart, jend, 1
3803                       DO i=istart, iend, 1
3804#endif
3805                          ic = ic + 1
3806                          sendIBuff(ic, isend) = ib3(i,j,k)
3807                       END DO
3808                    END DO
3809                 END DO
3810             END DO pack_patches3i
3811
3812             CALL MPI_Isend(sendIBuff(1,isend),ic,               &
3813                            MPI_INTEGER,                         &
3814                            destination(isend),tag,mpi_comm_opa, &
3815                            exch_flags(handle,isend,indexs),ierr)
3816          ENDIF
3817
3818          !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3819
3820       ELSE
3821
3822          exch_flags(handle,isend,indexs) = MPI_REQUEST_NULL
3823
3824       ENDIF ! direction is enabled and have something to send
3825
3826    ENDDO ! Loop over sends
3827
3828    ! CALL timing_stop('mpi_sends')
3829
3830#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
3831    WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3832#endif
3833
3834    ! Wait on the receives that were posted earlier
3835
3836    ! CALL timing_start('mpi_recvs')
3837
3838    ! Copy just the set of flags we're interested in for passing
3839    ! to MPI_waitany
3840    exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3841
3842#if defined DEBUG_COMMS
3843    WRITE(*,"(I3,': Doing waitany: nrecv =',I3,' handle = ',I3)") &
3844          narea-1, nrecv,handle
3845#endif
3846
3847    CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3848    IF ( ierr .NE. MPI_SUCCESS ) THEN
3849
3850       IF(ierr .EQ. MPI_ERR_REQUEST)THEN
3851          WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_REQUEST')") narea-1
3852       ELSE IF(ierr .EQ. MPI_ERR_ARG)THEN
3853          WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_ARG')") narea-1
3854       ELSE
3855          WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1
3856       END IF
3857       CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error')
3858    END IF
3859
3860    DO WHILE(irecv .ne. MPI_UNDEFINED)
3861
3862          IF ( PRESENT(b2) ) THEN
3863
3864             ! CALL timing_start('2dr_unpack')
3865
3866             ! Copy received data back into array
3867             ic = 0
3868             unpack_patches2r: DO ipatch=1,npatchrecv(irecv,nhexch)
3869
3870                jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3871                jend   = jstart+nyrecvp(ipatch,irecv,1)-1
3872                istart = idesrecvp(ipatch,irecv,1)!+nhalo
3873                iend   = istart+nxrecvp(ipatch,irecv,1)-1
3874                DO j=jstart, jend, 1
3875                   DO i=istart, iend, 1
3876                      ic = ic + 1
3877                      b2(i,j) = recvBuff(ic,irecv)
3878                   END DO
3879                END DO
3880             END DO unpack_patches2r
3881
3882             ! CALL timing_stop('2dr_unpack')
3883
3884          ELSE IF ( PRESENT(ib2) ) THEN
3885
3886             ! Copy received data back into array
3887             ic = 0
3888             unpack_patches2i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3889
3890                jstart = jdesrecvp(ipatch,irecv,1)
3891                jend   = jstart+nyrecvp(ipatch,irecv,1)-1
3892                istart = idesrecvp(ipatch,irecv,1)
3893                iend   = istart+nxrecvp(ipatch,irecv,1)-1
3894                DO j=jstart, jend, 1
3895                   DO i=istart, iend, 1
3896                      ic = ic + 1
3897                      ib2(i,j) = recvIBuff(ic,irecv)
3898                   END DO
3899                END DO
3900             END DO unpack_patches2i
3901
3902           ELSE IF (PRESENT(b3) ) THEN
3903
3904              ! CALL timing_start('3dr_unpack')
3905             ic = 0
3906             unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch)
3907
3908                jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3909                jend   = jstart+nyrecvp(ipatch,irecv,1)-1
3910                istart = idesrecvp(ipatch,irecv,1)!+nhalo
3911                iend   = istart+nxrecvp(ipatch,irecv,1)-1
3912#if defined key_z_first
3913                DO j=jstart, jend, 1
3914                   DO i=istart, iend, 1
3915                      DO k=1,nzrecvp(ipatch,irecv,1),1
3916#else
3917                DO k=1,nzrecvp(ipatch,irecv,1),1
3918                   DO j=jstart, jend, 1
3919                      DO i=istart, iend, 1
3920#endif
3921                         ic = ic + 1
3922                         b3(i,j,k) = recvBuff(ic,irecv)
3923                      END DO
3924#if defined key_z_first
3925                      ! ARPDBG - wipe anything below the ocean bottom
3926                      DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3927                         b3(i,j,k) = 0.0_wp
3928                      END DO
3929#endif
3930                   END DO
3931                END DO
3932
3933                ! ARPDBG - wipe anything below the ocean bottom
3934#if ! defined key_z_first
3935                DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3936                   DO j=jstart, jend, 1
3937                      DO i=istart, iend, 1
3938                         b3(i,j,k) = 0.0_wp
3939                      END DO
3940                   END DO
3941                END DO
3942#endif
3943
3944             END DO unpack_patches3r
3945
3946!             CALL timing_stop('3dr_unpack')
3947
3948          ELSEIF ( PRESENT(ib3) ) THEN
3949
3950             ic = 0
3951             unpack_patches3i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3952
3953                jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3954                jend   = jstart+nyrecvp(ipatch,irecv,1)-1
3955                istart = idesrecvp(ipatch,irecv,1)!+nhalo
3956                iend   = istart+nxrecvp(ipatch,irecv,1)-1
3957#if defined key_z_first
3958                DO j=jstart, jend, 1
3959                   DO i=istart, iend, 1
3960                      DO k=1,nzrecvp(ipatch,irecv,1),1
3961#else
3962                DO k=1,nzrecvp(ipatch,irecv,1),1
3963                   DO j=jstart, jend, 1
3964                      DO i=istart, iend, 1
3965#endif
3966                         ic = ic + 1
3967                         ib3(i,j,k) = recvIBuff(ic,irecv)
3968                      END DO
3969                   END DO
3970                END DO
3971             END DO unpack_patches3i
3972
3973          END IF
3974
3975       CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3976       !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3977
3978    END DO ! while irecv != MPI_UNDEFINED
3979
3980    ! CALL timing_stop('mpi_recvs')
3981
3982    ! All receives done and unpacked so can deallocate the associated
3983    ! buffers
3984    !IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)
3985    !IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
3986
3987#if defined DEBUG_COMMS
3988    WRITE(*,"(I3,': Finished all ',I3,' receives for handle ',I3)") &
3989             narea-1, nrecv, handle
3990#endif
3991
3992#endif /* key_mpp_mpi */
3993
3994    ! Periodic boundary condition using internal copy.
3995    ! This is performed after all data has been received so that we can
3996    ! also copy boundary points and avoid some diagonal communication.
3997    !
3998    ! ARPDBG - performance issue: need to hoist IF block outside nested
3999    !          loop!
4000    IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
4001
4002       ! Find out the sizes of the arrays.
4003       kdim1 = 1
4004       IF ( PRESENT(b3) ) THEN
4005          kdim1 = SIZE(b3,dim=index_z)
4006       ELSEIF ( PRESENT(ib3) ) THEN
4007          kdim1 = SIZE(ib3,dim=index_z)
4008       ENDIF
4009
4010
4011       IF ( enabled(Iplus) ) THEN
4012          !ARPDBG        DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4013          DO j=1,jesub+jpreci
4014             !ARPDBG           DO i=nhexch,1,-1
4015             DO i=1,jpreci
4016                IF ( PRESENT(b2) ) THEN
4017                   !ARPDBG                 b2(iesub-i+1,j) = b2(i,j)
4018                   b2(iesub+i,j) = b2(i,j)
4019                ELSEIF ( PRESENT(ib2) ) THEN
4020                   !ARPDBG                 ib2(iesub-i+1,j) = ib2(i,j)
4021                   ib2(iesub+i,j) = ib2(i,j)
4022                ELSEIF ( PRESENT(b3) ) THEN
4023                   ! dir$           unroll
4024                   DO k=1,kdim1
4025                      !ARPDBG                    b3(k,iesub-i+1,j) = b3(k,i,j)
4026                      b3(k,iesub+i,j) = b3(k,i,j)
4027                   ENDDO
4028                ELSEIF ( PRESENT(ib3) ) THEN
4029                   ! dir$           unroll
4030                   DO k=1,kdim1
4031                      !ARPDBG                    ib3(k,iesub-i+1,j) = ib3(k,i,j)
4032                      ib3(k,iesub+i,j) = ib3(k,i,j)
4033                   ENDDO
4034                ENDIF
4035             ENDDO
4036          ENDDO
4037       ENDIF
4038
4039       IF ( enabled(Iminus) ) THEN
4040          !ARPDBG        DO j=1,jesub,1
4041          DO j=1,jesub+jpreci
4042             DO i=1,jpreci
4043                IF ( PRESENT(b2) ) THEN
4044                   !ARPDBG                 b2(i,j) = b2(iesub-i+1,j)
4045                   b2(1-i,j) = b2(iesub-i+1,j)
4046                ELSEIF ( PRESENT(ib2) ) THEN
4047                   !ARPDBG                 ib2(i,j) = ib2(iesub-i+1,j)
4048                   ib2(1-i,j) = ib2(iesub-i+1,j)
4049                ELSEIF ( PRESENT(b3) ) THEN
4050                   ! dir$           unroll
4051                   DO k=1,kdim1
4052                      !ARPDBG                    b3(k,i,j) = b3(k,iesub-i+1,j)
4053                      b3(1-i,j,k) = b3(iesub-i+1,j,k)
4054                   ENDDO
4055                ELSEIF ( PRESENT(ib3) ) THEN
4056                   ! dir$           unroll
4057                   DO k=1,kdim1
4058                      !ARPDBG                    ib3(k,i,j) = ib3(k,iesub-i+1,j)
4059                      ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4060                   ENDDO
4061                ENDIF
4062             ENDDO
4063          ENDDO
4064       ENDIF
4065
4066    ENDIF ! cyclic_bc .AND. jpni == 1
4067
4068    ! Copy just the set of flags we're interested in for passing to 
4069    ! MPI_waitall next time around 
4070    exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
4071
4072    ! Free the exchange communications handle.
4073    CALL free_exch_handle(handle)
4074
4075    ! All receives done so we can safely free the MPI receive buffers
4076    IF( ALLOCATED(recvBuff) ) DEALLOCATE(recvBuff)
4077    IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff)
4078
4079    ! CALL timing_stop('exchs_generic')
4080    !CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat)
4081
4082  END SUBROUTINE exchs_generic
4083
4084  ! ********************************************************************
4085
4086!!$  SUBROUTINE exchr_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
4087!!$                             handle, comm1, comm2, comm3, comm4 )
4088!!$
4089!!$    ! ******************************************************************
4090!!$
4091!!$    ! Receive boundary data elements from adjacent sub-domains.
4092!!$
4093!!$    ! b2(1-nhalo:,1-nhalo:)     real   input       2D real*8 local array.
4094!!$    ! ib2(1-nhalo:,1-nhalo:)    int    input       2D integer local array.
4095!!$    ! b3(:,1-nhalo:,1-nhalo:)   real   input       3D real*8 local array.
4096!!$    ! ib3(:,1-nhalo:,1-nhalo:)  int    input       3D integer local array.
4097!!$    ! nhalo                     int    input       Width of halo.
4098!!$    ! nhexch                    int    input       Number of halo
4099!!$    ! rows/cols to exchange.
4100!!$    ! handle                    int    input       Exchange handle.
4101!!$    ! comm1                     int    input       Send in direction comm1.
4102!!$    ! comm2                     int    input       Send in direction comm2.
4103!!$    ! comm3                     int    input       Send in direction comm3.
4104!!$    ! comm4                     int    input       Send in direction comm4.
4105!!$
4106!!$    ! Mike Ashworth, CCLRC, March 2005.
4107!!$
4108!!$    ! ******************************************************************
4109!!$    USE mapcomm_mod, ONLY: iesub,jesub,MaxCommDir,Iplus,Jplus,Iminus, &
4110!!$         Jminus, IplusJplus,IminusJminus,IplusJminus, &
4111!!$         IminusJplus, nrecv, nxrecv,nyrecv, source, dirrecv, &
4112!!$         idesrecv, jdesrecv, cyclic_bc, destination, &
4113!!$         nsend, nxsend, dirsend
4114!!$    !ARPDBG: do_exchanges below is debug only
4115!!$    USE par_oce, ONLY: jpni, jpreci, wp, do_exchanges
4116!!$    USE lib_mpp, ONLY: mpi_comm_opa
4117!!$    USE dom_oce, ONLY: narea
4118!!$#ifdef WITH_LIBHMD
4119!!$    USE in_out_manager, ONLY: lwp
4120!!$#endif
4121!!$    IMPLICIT NONE
4122!!$
4123!!$    INTEGER :: status(MPI_status_size)
4124!!$
4125!!$    ! Subroutine arguments.
4126!!$!xxFTRANS b3  :I :I :z
4127!!$!xxFTRANS ib3 :I :I :z
4128!!$    INTEGER,  INTENT(In) :: nhalo,nhexch,handle
4129!!$    REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:) :: b2
4130!!$    INTEGER,  INTENT(inout), OPTIONAL, DIMENSION(:,:) :: ib2
4131!!$    REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: b3
4132!!$    INTEGER,  INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: ib3
4133!!$    INTEGER,  INTENT(in) :: comm1, comm2, comm3, comm4
4134!!$
4135!!$    ! Local variables.
4136!!$
4137!!$    LOGICAL :: enabled(0:MaxCommDir)
4138!!$    INTEGER :: i, ides, ierr, irecv, isend, j, jdes, k, &
4139!!$               kdim1, nxr, nyr
4140!!$
4141!!$#ifdef PARALLEL_STATS
4142!!$    LOGICAL :: probe
4143!!$    INTEGER :: nbpw
4144!!$#endif
4145!!$
4146!!$    IF(.not. do_exchanges)THEN
4147!!$       WRITE (*,*) 'ARPDBG: exchr_generic: do_exchanges is FALSE'
4148!!$       RETURN ! ARPDBG
4149!!$    END IF
4150!!$
4151!!$#ifdef PARALLEL_STATS
4152!!$    IF ( PRESENT(b2) .OR. PRESENT(b3) ) THEN
4153!!$       nbpw = 8
4154!!$    ELSE
4155!!$       nbpw = nbpi
4156!!$    ENDIF
4157!!$#endif
4158!!$
4159!!$    ! Find out the sizes of the arrays.
4160!!$
4161!!$    kdim1 = 1
4162!!$    IF ( PRESENT(b3) ) THEN
4163!!$!! DCSE_NEMO - bug here in original code?
4164!!$! Code used to say kdim1 = SIZE(b3,dim=1) whereas ARP thinks it should
4165!!$! have had dim=3. Ditto for ib3 below.
4166!!$#if defined key_z_first
4167!!$       kdim1 = SIZE(b3,dim=1)
4168!!$#else
4169!!$       kdim1 = SIZE(b3,dim=3)
4170!!$#endif
4171!!$!       isizes(3) = kdim1
4172!!$!       isizes(2) = SIZE(b3,dim=2)
4173!!$!       isizes(1) = SIZE(b3,dim=1)
4174!!$    ELSEIF ( PRESENT(ib3) ) THEN
4175!!$#if defined key_z_first
4176!!$       kdim1 = SIZE(ib3,dim=1)
4177!!$#else
4178!!$       kdim1 = SIZE(ib3,dim=3)
4179!!$#endif
4180!!$!       isizes(3) = kdim1
4181!!$!       isizes(2) = SIZE(ib3,dim=2)
4182!!$!       isizes(1) = SIZE(ib3,dim=1)
4183!!$    ENDIF
4184!!$
4185!!$    ! Check nhexch is in range.
4186!!$
4187!!$    IF ( nhexch.GT.jpreci ) THEN
4188!!$       STOP 'exchr: halo width greater than maximum'
4189!!$    ENDIF
4190!!$
4191!!$        ! Set enabled flags according to the subroutine arguments.
4192!!$
4193!!$    enabled(Iplus ) = .FALSE.
4194!!$    enabled(Jplus ) = .FALSE.
4195!!$    enabled(Iminus) = .FALSE.
4196!!$    enabled(Jminus) = .FALSE.
4197!!$    enabled(comm1) = comm1.GT.0
4198!!$    enabled(comm2) = comm2.GT.0
4199!!$    enabled(comm3) = comm3.GT.0
4200!!$    enabled(comm4) = comm4.GT.0
4201!!$
4202!!$    ! Set diagonal communications according to the non-diagonal flags.
4203!!$
4204!!$    enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
4205!!$    enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
4206!!$    enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
4207!!$    enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
4208!!$
4209!!$    ! Main communications loop.
4210!!$
4211!!$    ! Receive all messages in the communications list.
4212!!$
4213!!$    DO irecv=1,nrecv
4214!!$
4215!!$       IF ( enabled(dirrecv(irecv)) .AND. source(irecv).GE.0 &
4216!!$!            .AND. nxrecv(irecv,nhexch).GT.0 ) THEN
4217!!$            .AND. nxrecv(irecv).GT.0 ) THEN
4218!!$
4219!!$!          ides = idesrecv(irecv,nhexch)
4220!!$!          jdes = jdesrecv(irecv,nhexch)
4221!!$!          nxr  =   nxrecv(irecv,nhexch)
4222!!$!          nyr  =   nyrecv(irecv,nhexch)
4223!!$          ides = idesrecv(irecv)
4224!!$          jdes = jdesrecv(irecv)
4225!!$          nxr  =   nxrecv(irecv)
4226!!$          nyr  =   nyrecv(irecv)
4227!!$
4228!!$          ! Wait on the receives that were actually posted in the send routine
4229!!$
4230!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
4231!!$          WRITE (*,FMT="(I4,': test for recv from ',I3,' data ',I3,' x ',I3,' to ',I3,I3)") narea-1,source(irecv),nxr,nyr,ides,jdes
4232!!$          WRITE (*,FMT="(I4,': test flag = ',I3)") narea-1, &
4233!!$                                  exch_flags(handle,irecv,indexr)
4234!!$#endif
4235!!$
4236!!$#ifdef PARALLEL_STATS
4237!!$          CALL MPI_test (exch_flags(handle,irecv,indexr),probe,status,ierr)
4238!!$          IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4239!!$          IF ( .NOT.probe ) THEN
4240!!$             nmwait = nmwait+1
4241!!$          ENDIF
4242!!$#endif /* PARALLEL_STATS */
4243!!$          CALL MPI_wait (exch_flags(handle,irecv,indexr),status,ierr)
4244!!$          IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4245!!$
4246!!$#ifdef PARALLEL_STATS
4247!!$          nmrecv = nmrecv + 1
4248!!$          nbrecv = nbrecv + kdim1*nbpw*nxr*nyr
4249!!$
4250!!$#endif /* PARALLEL_STATS */
4251!!$       ENDIF
4252!!$
4253!!$    ENDDO
4254!!$
4255!!$    ! Periodic boundary condition using internal copy.
4256!!$    ! This is performed after all data has been received so that we can
4257!!$    ! also copy boundary points and avoid some diagonal communication.
4258!!$
4259!!$    IF ( cyclic_bc .AND. jpni.EQ.1 ) THEN
4260!!$
4261!!$       IF ( enabled(Iplus) ) THEN
4262!!$          !ARPDBG        DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4263!!$!ARPDBG - broken? Loop over j is used as 3rd index in 3D arrays
4264!!$!ARPDBG   but kdim1 is correctly(?) set to extent of first dimension
4265!!$          DO j=1,jesub+jpreci
4266!!$             !ARPDBG           DO i=nhexch,1,-1
4267!!$             DO i=1,jpreci
4268!!$                IF ( PRESENT(b2) ) THEN
4269!!$                   !ARPDBG                 b2(iesub-i+1,j) = b2(i,j)
4270!!$                   b2(iesub+i,j) = b2(i,j)
4271!!$                ELSEIF ( PRESENT(ib2) ) THEN
4272!!$                   !ARPDBG                 ib2(iesub-i+1,j) = ib2(i,j)
4273!!$                   ib2(iesub+i,j) = ib2(i,j)
4274!!$                ELSEIF ( PRESENT(b3) ) THEN
4275!!$                   ! dir$           unroll
4276!!$                   DO k=1,kdim1
4277!!$                      !ARPDBG                    b3(k,iesub-i+1,j) = b3(k,i,j)
4278!!$                      b3(k,iesub+i,j) = b3(k,i,j)
4279!!$                   ENDDO
4280!!$                ELSEIF ( PRESENT(ib3) ) THEN
4281!!$                   ! dir$           unroll
4282!!$                   DO k=1,kdim1
4283!!$                      !ARPDBG                    ib3(k,iesub-i+1,j) = ib3(k,i,j)
4284!!$                      ib3(k,iesub+i,j) = ib3(k,i,j)
4285!!$                   ENDDO
4286!!$                ENDIF
4287!!$             ENDDO
4288!!$          ENDDO
4289!!$       ENDIF
4290!!$
4291!!$       IF ( enabled(Iminus) ) THEN
4292!!$          !ARPDBG        DO j=1,jesub,1
4293!!$          DO j=1,jesub+jpreci
4294!!$             DO i=1,jpreci
4295!!$                IF ( PRESENT(b2) ) THEN
4296!!$                   !ARPDBG                 b2(i,j) = b2(iesub-i+1,j)
4297!!$                   b2(1-i,j) = b2(iesub-i+1,j)
4298!!$                ELSEIF ( PRESENT(ib2) ) THEN
4299!!$                   !ARPDBG                 ib2(i,j) = ib2(iesub-i+1,j)
4300!!$                   ib2(1-i,j) = ib2(iesub-i+1,j)
4301!!$                ELSEIF ( PRESENT(b3) ) THEN
4302!!$                   ! dir$           unroll
4303!!$                   DO k=1,kdim1
4304!!$                      !ARPDBG                    b3(k,i,j) = b3(k,iesub-i+1,j)
4305!!$                      b3(1-i,j,k) = b3(iesub-i+1,j,k)
4306!!$                   ENDDO
4307!!$                ELSEIF ( PRESENT(ib3) ) THEN
4308!!$                   ! dir$           unroll
4309!!$                   DO k=1,kdim1
4310!!$                      !ARPDBG                    ib3(k,i,j) = ib3(k,iesub-i+1,j)
4311!!$                      ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4312!!$                   ENDDO
4313!!$                ENDIF
4314!!$             ENDDO
4315!!$          ENDDO
4316!!$       ENDIF
4317!!$
4318!!$    ENDIF
4319!!$
4320!!$    IF ( immed ) THEN
4321!!$
4322!!$       ! Check completion for immediate sends.
4323!!$
4324!!$       DO isend=1,nsend
4325!!$
4326!!$          IF (enabled(dirsend(isend)) .AND. &
4327!!$               destination(isend).GE.0 .AND. nxsend(isend,nhexch).GT.0 ) THEN
4328!!$
4329!!$             CALL MPI_wait (exch_flags(handle,isend,indexs),status,ierr)
4330!!$             IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4331!!$
4332!!$          ENDIF
4333!!$
4334!!$       ENDDO
4335!!$
4336!!$    ENDIF
4337!!$
4338!!$    ! Free the exchange communications handle.
4339!!$
4340!!$    CALL free_exch_handle(handle)
4341!!$
4342!!$  END SUBROUTINE exchr_generic
4343
4344  !=======================================================================
4345
4346  SUBROUTINE mpp_lbc_north_list(list, nfields)
4347    USE par_oce,     ONLY : jpni, jpi, jpj
4348    USE dom_oce,     ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
4349                            nwidthmax
4350    USE mapcomm_mod, ONLY : pielb, piesub
4351    USE lib_mpp,     ONLY : ctl_stop
4352    IMPLICIT none
4353    ! Subroutine arguments.
4354    TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
4355    INTEGER,                           INTENT(in) :: nfields 
4356
4357    !! * Local declarations
4358    INTEGER :: ijpj  ! No. of rows to operate upon
4359    INTEGER :: ii, ji, jj,  jk, jji, jjr, jr, jproc, klimit
4360    INTEGER :: ierr, ifield, ishifti, ishiftr
4361    INTEGER :: ildi,ilei,iilb
4362    INTEGER :: ij,ijt,iju, isgn
4363    INTEGER :: itaille
4364!FTRANS ztab :I :I :z
4365!FTRANS iztab :I :I :z
4366!FTRANS znorthgloio :I :I :z :
4367!FTRANS iznorthgloio :I :I :z :
4368!FTRANS znorthloc :I :I :z
4369!FTRANS iznorthloc :I :I :z
4370    INTEGER,  DIMENSION(:,:,:),   ALLOCATABLE, SAVE :: iztab
4371    INTEGER,  DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: iznorthgloio
4372    INTEGER,  DIMENSION(:,:,:),   ALLOCATABLE, SAVE :: iznorthloc
4373    REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE, SAVE :: ztab
4374    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio
4375    REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE, SAVE :: znorthloc
4376    REAL(wp) :: psgn          ! control of the sign change
4377    LOGICAL :: field_is_real, fields_all_real, fields_all_int
4378    LOGICAL :: fields_all_3d, fields_all_2d
4379    !!----------------------------------------------------------------------
4380
4381    CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat)
4382
4383#if defined key_mpp_mpi
4384
4385    ! If we get into this routine it's because : North fold condition and mpp
4386    ! with more than one PE across i : we deal only with the North condition
4387
4388    ! Set no. of rows from a module parameter that is also used in exchtestmod
4389    ! and mpp_ini_north
4390    ijpj = num_nfold_rows
4391
4392    ! Allocate work-space arrays
4393    IF(.not. ALLOCATED(ztab))THEN
4394
4395       ALLOCATE(ztab(jpiglo,maxExchItems*ijpj,jpk),                 &
4396                iztab(jpiglo,maxExchItems*ijpj,jpk),                &
4397                znorthgloio(nwidthmax,maxExchItems*ijpj,jpk,jpni),  &
4398                znorthloc(nwidthmax,maxExchItems*ijpj,jpk),         &
4399                iznorthgloio(nwidthmax,maxExchItems*ijpj,jpk,jpni), &
4400                iznorthloc(nwidthmax,maxExchItems*ijpj,jpk),        &
4401                STAT=ierr)
4402       IF(ierr .ne. 0)THEN
4403          CALL ctl_stop('STOP','mpp_lbc_north_list: memory allocation failed')
4404          RETURN
4405       END IF
4406    END IF
4407
4408    ! put the last ijpj jlines of each real field into znorthloc
4409!    znorthloc(:,:,:)  = 0_wp ! because of padding for nwidthmax
4410!    iznorthloc(:,:,:) = 0
4411    ishiftr = 0
4412    ishifti = 0
4413    fields_all_real = .TRUE.
4414    fields_all_int  = .TRUE.
4415    fields_all_3d   = .TRUE.
4416    fields_all_2d   = .TRUE.
4417
4418    CALL prof_region_begin(NORTHLISTGATHER, "NorthListGather", iprofStat)
4419
4420    DO ifield=1,nfields,1
4421
4422       IF(ASSOCIATED(list(ifield)%r2dptr))THEN
4423          DO ij = 1, ijpj, 1
4424             jj = nlcj - ijpj + ij
4425             znorthloc(nldi:nlei,ij+ishiftr,1) = &
4426                                  list(ifield)%r2dptr(nldi:nlei,jj)
4427          END DO
4428
4429          ishiftr = ishiftr + ijpj
4430          fields_all_int = .FALSE.
4431          fields_all_3d  = .FALSE.
4432       ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
4433
4434#if defined key_z_first
4435          DO ij = 1, ijpj, 1
4436             jj = nlcj - ijpj + ij
4437             DO ii = nldi, nlei, 1
4438                DO jk = 1, jpk 
4439#else
4440          DO jk = 1, jpk 
4441             DO ij = 1