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

Last change on this file since 4409 was 4409, checked in by trackstand2, 7 years ago

Changes to allow jpk to be modified to deepest level within a subdomain. jpkorig holds original value.

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