New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
exchmod.F90 in branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

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

Last change on this file since 4476 was 4476, checked in by trackstand2, 10 years ago

Remove col-trimming when halo packing as is broken - recvs need to know about it too and currently they cannot.

File size: 230.8 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, mbkmax
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                jstart = jsrcsendp(ipatch,isend,1)
3760                istart = isrcsendp(ipatch,isend,1)
3761                jend   = jstart+nysendp(ipatch,isend,1)-1
3762                iend   = istart+nxsendp(ipatch,isend,1)-1
3763#if defined key_z_first
3764                DO j=jstart, jend, 1
3765                   DO i=istart, iend, 1
3766#if defined key_halo_column_trim
3767                      ARPDBG: THIS FUNCTIONALITY IS NOT YET IMPLEMENTED!
3768                              Need to supply accurate point count to the
3769                              mpi recv and that requires extension of 
3770                              the mapcomm_mod::clip_msg() routine.
3771                      DO k=1,mbkmax(i,j),1
3772#else
3773                      DO k=1, nzsendp(ipatch,isend,1),1
3774#endif
3775#else
3776                DO k=1,nzsendp(ipatch,isend,1),1
3777                   DO j=jstart, jend, 1
3778                      DO i=istart, iend, 1
3779#endif
3780                         ic = ic + 1
3781                         sendBuff(ic, isend) = b3(i,j,k)
3782                      END DO
3783                   END DO
3784                END DO
3785             END DO pack_patches3r
3786
3787             ! CALL timing_stop('3dr_pack')
3788
3789             CALL MPI_Isend(sendBuff(1,isend),ic,                  &
3790                            MPI_DOUBLE_PRECISION,                  &
3791                            destination(isend), tag, mpi_comm_opa, &
3792                            exch_flags(handle,isend,indexs),ierr)
3793
3794#if defined DEBUG_COMMS
3795             WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &
3796                     narea-1, npatchsend(isend,1),ic, &
3797                     destination(isend)
3798#endif
3799
3800           ELSEIF ( PRESENT(ib3) ) THEN
3801
3802              ic = 0
3803              pack_patches3i: DO ipatch=1,npatchsend(isend,1)
3804                 jstart = jsrcsendp(ipatch,isend,1) !+nhalo
3805                 istart = isrcsendp(ipatch,isend,1) !+nhalo
3806                 jend   = jstart+nysendp(ipatch,isend,1)-1
3807                 iend   = istart+nxsendp(ipatch,isend,1)-1
3808#if defined key_z_first
3809                 DO j=jstart, jend, 1
3810                    DO i=istart, iend, 1
3811#if defined key_halo_column_trim
3812                       DO k=1,mbkmax(i,j),1
3813#else
3814                       DO k=1, nzsendp(ipatch,isend,1),1
3815#endif
3816#else
3817                 DO k=1,nzsendp(ipatch,isend,1),1
3818                    DO j=jstart, jend, 1
3819                       DO i=istart, iend, 1
3820#endif
3821                          ic = ic + 1
3822                          sendIBuff(ic, isend) = ib3(i,j,k)
3823                       END DO
3824                    END DO
3825                 END DO
3826             END DO pack_patches3i
3827
3828             CALL MPI_Isend(sendIBuff(1,isend),ic,               &
3829                            MPI_INTEGER,                         &
3830                            destination(isend),tag,mpi_comm_opa, &
3831                            exch_flags(handle,isend,indexs),ierr)
3832          ENDIF
3833
3834          !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3835
3836       ELSE
3837
3838          exch_flags(handle,isend,indexs) = MPI_REQUEST_NULL
3839
3840       ENDIF ! direction is enabled and have something to send
3841
3842    ENDDO ! Loop over sends
3843
3844    ! CALL timing_stop('mpi_sends')
3845
3846#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
3847    WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3848#endif
3849
3850    ! Wait on the receives that were posted earlier
3851
3852    ! CALL timing_start('mpi_recvs')
3853
3854    ! Copy just the set of flags we're interested in for passing
3855    ! to MPI_waitany
3856    exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3857
3858#if defined DEBUG_COMMS
3859    WRITE(*,"(I3,': Doing waitany: nrecv =',I3,' handle = ',I3)") &
3860          narea-1, nrecv,handle
3861#endif
3862
3863    CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3864    IF ( ierr .NE. MPI_SUCCESS ) THEN
3865
3866       IF(ierr .EQ. MPI_ERR_REQUEST)THEN
3867          WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_REQUEST')") narea-1
3868       ELSE IF(ierr .EQ. MPI_ERR_ARG)THEN
3869          WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_ARG')") narea-1
3870       ELSE
3871          WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1
3872       END IF
3873       CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error')
3874    END IF
3875
3876    DO WHILE(irecv .ne. MPI_UNDEFINED)
3877
3878          IF ( PRESENT(b2) ) THEN
3879
3880             ! CALL timing_start('2dr_unpack')
3881
3882             ! Copy received data back into array
3883             ic = 0
3884             unpack_patches2r: DO ipatch=1,npatchrecv(irecv,nhexch)
3885
3886                jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3887                jend   = jstart+nyrecvp(ipatch,irecv,1)-1
3888                istart = idesrecvp(ipatch,irecv,1)!+nhalo
3889                iend   = istart+nxrecvp(ipatch,irecv,1)-1
3890                DO j=jstart, jend, 1
3891                   DO i=istart, iend, 1
3892                      ic = ic + 1
3893                      b2(i,j) = recvBuff(ic,irecv)
3894                   END DO
3895                END DO
3896             END DO unpack_patches2r
3897
3898             ! CALL timing_stop('2dr_unpack')
3899
3900          ELSE IF ( PRESENT(ib2) ) THEN
3901
3902             ! Copy received data back into array
3903             ic = 0
3904             unpack_patches2i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3905
3906                jstart = jdesrecvp(ipatch,irecv,1)
3907                jend   = jstart+nyrecvp(ipatch,irecv,1)-1
3908                istart = idesrecvp(ipatch,irecv,1)
3909                iend   = istart+nxrecvp(ipatch,irecv,1)-1
3910                DO j=jstart, jend, 1
3911                   DO i=istart, iend, 1
3912                      ic = ic + 1
3913                      ib2(i,j) = recvIBuff(ic,irecv)
3914                   END DO
3915                END DO
3916             END DO unpack_patches2i
3917
3918           ELSE IF (PRESENT(b3) ) THEN
3919
3920              ! CALL timing_start('3dr_unpack')
3921             ic = 0
3922             unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch)
3923
3924                jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3925                jend   = jstart+nyrecvp(ipatch,irecv,1)-1
3926                istart = idesrecvp(ipatch,irecv,1)!+nhalo
3927                iend   = istart+nxrecvp(ipatch,irecv,1)-1
3928
3929#if defined key_z_first
3930                DO j=jstart, jend, 1
3931                   DO i=istart, iend, 1
3932#if defined key_halo_column_trim
3933                      DO k=1,mbkmax(i,j),1
3934#else
3935                      DO k=1, nzrecvp(ipatch,irecv,1),1
3936#endif
3937#else
3938                DO k=1,nzrecvp(ipatch,irecv,1),1
3939                   DO j=jstart, jend, 1
3940                      DO i=istart, iend, 1
3941#endif
3942                         ic = ic + 1
3943                         b3(i,j,k) = recvBuff(ic,irecv)
3944                      END DO
3945#if defined key_z_first
3946                      ! ARPDBG - wipe anything below the ocean bottom
3947#if defined key_halo_column_trim
3948                      b3(i,j,mbkmax(i,j)+1:jpk) = 0.0_wp
3949#else
3950                      b3(i,j,nzrecvp(ipatch,irecv,1)+1:jpk) = 0.0_wp
3951#endif
3952#endif
3953                   END DO
3954                END DO
3955
3956                ! ARPDBG - wipe anything below the ocean bottom
3957#if ! defined key_z_first
3958                DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3959                   DO j=jstart, jend, 1
3960                      DO i=istart, iend, 1
3961                         b3(i,j,k) = 0.0_wp
3962                      END DO
3963                   END DO
3964                END DO
3965#endif
3966
3967             END DO unpack_patches3r
3968
3969!             CALL timing_stop('3dr_unpack')
3970
3971          ELSEIF ( PRESENT(ib3) ) THEN
3972
3973             ic = 0
3974             unpack_patches3i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3975
3976                jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3977                jend   = jstart+nyrecvp(ipatch,irecv,1)-1
3978                istart = idesrecvp(ipatch,irecv,1)!+nhalo
3979                iend   = istart+nxrecvp(ipatch,irecv,1)-1
3980#if defined key_z_first
3981                DO j=jstart, jend, 1
3982                   DO i=istart, iend, 1
3983#if defined key_halo_column_trim
3984                      DO k=1,mbkmax(i,j),1
3985#else
3986                      DO k=1,nzrecvp(ipatch,irecv,1),1
3987#endif
3988#else
3989                DO k=1,nzrecvp(ipatch,irecv,1),1
3990                   DO j=jstart, jend, 1
3991                      DO i=istart, iend, 1
3992#endif
3993                         ic = ic + 1
3994                         ib3(i,j,k) = recvIBuff(ic,irecv)
3995                      END DO
3996                   END DO
3997                END DO
3998             END DO unpack_patches3i
3999
4000          END IF
4001
4002       CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
4003       !IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4004
4005    END DO ! while irecv != MPI_UNDEFINED
4006
4007    ! CALL timing_stop('mpi_recvs')
4008
4009    ! All receives done and unpacked so can deallocate the associated
4010    ! buffers
4011    !IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)
4012    !IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
4013
4014#if defined DEBUG_COMMS
4015    WRITE(*,"(I3,': Finished all ',I3,' receives for handle ',I3)") &
4016             narea-1, nrecv, handle
4017#endif
4018
4019#endif /* key_mpp_mpi */
4020
4021    ! Periodic boundary condition using internal copy.
4022    ! This is performed after all data has been received so that we can
4023    ! also copy boundary points and avoid some diagonal communication.
4024    !
4025    ! ARPDBG - performance issue: need to hoist IF block outside nested
4026    !          loop!
4027    IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
4028
4029       ! Find out the sizes of the arrays.
4030       kdim1 = 1
4031       IF ( PRESENT(b3) ) THEN
4032          kdim1 = SIZE(b3,dim=index_z)
4033       ELSEIF ( PRESENT(ib3) ) THEN
4034          kdim1 = SIZE(ib3,dim=index_z)
4035       ENDIF
4036
4037
4038       IF ( enabled(Iplus) ) THEN
4039          !ARPDBG        DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4040          DO j=1,jesub+jpreci
4041             !ARPDBG           DO i=nhexch,1,-1
4042             DO i=1,jpreci
4043                IF ( PRESENT(b2) ) THEN
4044                   !ARPDBG                 b2(iesub-i+1,j) = b2(i,j)
4045                   b2(iesub+i,j) = b2(i,j)
4046                ELSEIF ( PRESENT(ib2) ) THEN
4047                   !ARPDBG                 ib2(iesub-i+1,j) = ib2(i,j)
4048                   ib2(iesub+i,j) = ib2(i,j)
4049                ELSEIF ( PRESENT(b3) ) THEN
4050                   ! dir$           unroll
4051                   DO k=1,kdim1
4052                      !ARPDBG                    b3(k,iesub-i+1,j) = b3(k,i,j)
4053                      b3(k,iesub+i,j) = b3(k,i,j)
4054                   ENDDO
4055                ELSEIF ( PRESENT(ib3) ) THEN
4056                   ! dir$           unroll
4057                   DO k=1,kdim1
4058                      !ARPDBG                    ib3(k,iesub-i+1,j) = ib3(k,i,j)
4059                      ib3(k,iesub+i,j) = ib3(k,i,j)
4060                   ENDDO
4061                ENDIF
4062             ENDDO
4063          ENDDO
4064       ENDIF
4065
4066       IF ( enabled(Iminus) ) THEN
4067          !ARPDBG        DO j=1,jesub,1
4068          DO j=1,jesub+jpreci
4069             DO i=1,jpreci
4070                IF ( PRESENT(b2) ) THEN
4071                   !ARPDBG                 b2(i,j) = b2(iesub-i+1,j)
4072                   b2(1-i,j) = b2(iesub-i+1,j)
4073                ELSEIF ( PRESENT(ib2) ) THEN
4074                   !ARPDBG                 ib2(i,j) = ib2(iesub-i+1,j)
4075                   ib2(1-i,j) = ib2(iesub-i+1,j)
4076                ELSEIF ( PRESENT(b3) ) THEN
4077                   ! dir$           unroll
4078                   DO k=1,kdim1
4079                      !ARPDBG                    b3(k,i,j) = b3(k,iesub-i+1,j)
4080                      b3(1-i,j,k) = b3(iesub-i+1,j,k)
4081                   ENDDO
4082                ELSEIF ( PRESENT(ib3) ) THEN
4083                   ! dir$           unroll
4084                   DO k=1,kdim1
4085                      !ARPDBG                    ib3(k,i,j) = ib3(k,iesub-i+1,j)
4086                      ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4087                   ENDDO
4088                ENDIF
4089             ENDDO
4090          ENDDO
4091       ENDIF
4092
4093    ENDIF ! cyclic_bc .AND. jpni == 1
4094
4095    ! Copy just the set of flags we're interested in for passing to 
4096    ! MPI_waitall next time around 
4097    exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
4098
4099    ! Free the exchange communications handle.
4100    CALL free_exch_handle(handle)
4101
4102    ! All receives done so we can safely free the MPI receive buffers
4103    IF( ALLOCATED(recvBuff) ) DEALLOCATE(recvBuff)
4104    IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff)
4105
4106    CALL timing_stop('exchs_generic','section')
4107    !CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat)
4108
4109  END SUBROUTINE exchs_generic
4110
4111  ! ********************************************************************
4112
4113!!$  SUBROUTINE exchr_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
4114!!$                             handle, comm1, comm2, comm3, comm4 )
4115!!$
4116!!$    ! ******************************************************************
4117!!$
4118!!$    ! Receive boundary data elements from adjacent sub-domains.
4119!!$
4120!!$    ! b2(1-nhalo:,1-nhalo:)     real   input       2D real*8 local array.
4121!!$    ! ib2(1-nhalo:,1-nhalo:)    int    input       2D integer local array.
4122!!$    ! b3(:,1-nhalo:,1-nhalo:)   real   input       3D real*8 local array.
4123!!$    ! ib3(:,1-nhalo:,1-nhalo:)  int    input       3D integer local array.
4124!!$    ! nhalo                     int    input       Width of halo.
4125!!$    ! nhexch                    int    input       Number of halo
4126!!$    ! rows/cols to exchange.
4127!!$    ! handle                    int    input       Exchange handle.
4128!!$    ! comm1                     int    input       Send in direction comm1.
4129!!$    ! comm2                     int    input       Send in direction comm2.
4130!!$    ! comm3                     int    input       Send in direction comm3.
4131!!$    ! comm4                     int    input       Send in direction comm4.
4132!!$
4133!!$    ! Mike Ashworth, CCLRC, March 2005.
4134!!$
4135!!$    ! ******************************************************************
4136!!$    USE mapcomm_mod, ONLY: iesub,jesub,MaxCommDir,Iplus,Jplus,Iminus, &
4137!!$         Jminus, IplusJplus,IminusJminus,IplusJminus, &
4138!!$         IminusJplus, nrecv, nxrecv,nyrecv, source, dirrecv, &
4139!!$         idesrecv, jdesrecv, cyclic_bc, destination, &
4140!!$         nsend, nxsend, dirsend
4141!!$    !ARPDBG: do_exchanges below is debug only
4142!!$    USE par_oce, ONLY: jpni, jpreci, wp, do_exchanges
4143!!$    USE lib_mpp, ONLY: mpi_comm_opa
4144!!$    USE dom_oce, ONLY: narea
4145!!$#ifdef WITH_LIBHMD
4146!!$    USE in_out_manager, ONLY: lwp
4147!!$#endif
4148!!$    IMPLICIT NONE
4149!!$
4150!!$    INTEGER :: status(MPI_status_size)
4151!!$
4152!!$    ! Subroutine arguments.
4153!!$!xxFTRANS b3  :I :I :z
4154!!$!xxFTRANS ib3 :I :I :z
4155!!$    INTEGER,  INTENT(In) :: nhalo,nhexch,handle
4156!!$    REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:) :: b2
4157!!$    INTEGER,  INTENT(inout), OPTIONAL, DIMENSION(:,:) :: ib2
4158!!$    REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: b3
4159!!$    INTEGER,  INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: ib3
4160!!$    INTEGER,  INTENT(in) :: comm1, comm2, comm3, comm4
4161!!$
4162!!$    ! Local variables.
4163!!$
4164!!$    LOGICAL :: enabled(0:MaxCommDir)
4165!!$    INTEGER :: i, ides, ierr, irecv, isend, j, jdes, k, &
4166!!$               kdim1, nxr, nyr
4167!!$
4168!!$#ifdef PARALLEL_STATS
4169!!$    LOGICAL :: probe
4170!!$    INTEGER :: nbpw
4171!!$#endif
4172!!$
4173!!$    IF(.not. do_exchanges)THEN
4174!!$       WRITE (*,*) 'ARPDBG: exchr_generic: do_exchanges is FALSE'
4175!!$       RETURN ! ARPDBG
4176!!$    END IF
4177!!$
4178!!$#ifdef PARALLEL_STATS
4179!!$    IF ( PRESENT(b2) .OR. PRESENT(b3) ) THEN
4180!!$       nbpw = 8
4181!!$    ELSE
4182!!$       nbpw = nbpi
4183!!$    ENDIF
4184!!$#endif
4185!!$
4186!!$    ! Find out the sizes of the arrays.
4187!!$
4188!!$    kdim1 = 1
4189!!$    IF ( PRESENT(b3) ) THEN
4190!!$!! DCSE_NEMO - bug here in original code?
4191!!$! Code used to say kdim1 = SIZE(b3,dim=1) whereas ARP thinks it should
4192!!$! have had dim=3. Ditto for ib3 below.
4193!!$#if defined key_z_first
4194!!$       kdim1 = SIZE(b3,dim=1)
4195!!$#else
4196!!$       kdim1 = SIZE(b3,dim=3)
4197!!$#endif
4198!!$!       isizes(3) = kdim1
4199!!$!       isizes(2) = SIZE(b3,dim=2)
4200!!$!       isizes(1) = SIZE(b3,dim=1)
4201!!$    ELSEIF ( PRESENT(ib3) ) THEN
4202!!$#if defined key_z_first
4203!!$       kdim1 = SIZE(ib3,dim=1)
4204!!$#else
4205!!$       kdim1 = SIZE(ib3,dim=3)
4206!!$#endif
4207!!$!       isizes(3) = kdim1
4208!!$!       isizes(2) = SIZE(ib3,dim=2)
4209!!$!       isizes(1) = SIZE(ib3,dim=1)
4210!!$    ENDIF
4211!!$
4212!!$    ! Check nhexch is in range.
4213!!$
4214!!$    IF ( nhexch.GT.jpreci ) THEN
4215!!$       STOP 'exchr: halo width greater than maximum'
4216!!$    ENDIF
4217!!$
4218!!$        ! Set enabled flags according to the subroutine arguments.
4219!!$
4220!!$    enabled(Iplus ) = .FALSE.
4221!!$    enabled(Jplus ) = .FALSE.
4222!!$    enabled(Iminus) = .FALSE.
4223!!$    enabled(Jminus) = .FALSE.
4224!!$    enabled(comm1) = comm1.GT.0
4225!!$    enabled(comm2) = comm2.GT.0
4226!!$    enabled(comm3) = comm3.GT.0
4227!!$    enabled(comm4) = comm4.GT.0
4228!!$
4229!!$    ! Set diagonal communications according to the non-diagonal flags.
4230!!$
4231!!$    enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
4232!!$    enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
4233!!$    enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
4234!!$    enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
4235!!$
4236!!$    ! Main communications loop.
4237!!$
4238!!$    ! Receive all messages in the communications list.
4239!!$
4240!!$    DO irecv=1,nrecv
4241!!$
4242!!$       IF ( enabled(dirrecv(irecv)) .AND. source(irecv).GE.0 &
4243!!$!            .AND. nxrecv(irecv,nhexch).GT.0 ) THEN
4244!!$            .AND. nxrecv(irecv).GT.0 ) THEN
4245!!$
4246!!$!          ides = idesrecv(irecv,nhexch)
4247!!$!          jdes = jdesrecv(irecv,nhexch)
4248!!$!          nxr  =   nxrecv(irecv,nhexch)
4249!!$!          nyr  =   nyrecv(irecv,nhexch)
4250!!$          ides = idesrecv(irecv)
4251!!$          jdes = jdesrecv(irecv)
4252!!$          nxr  =   nxrecv(irecv)
4253!!$          nyr  =   nyrecv(irecv)
4254!!$
4255!!$          ! Wait on the receives that were actually posted in the send routine
4256!!$
4257!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) || defined DEBUG_COMMS
4258!!$          WRITE (*,FMT="(I4,': test for recv from ',I3,' data ',I3,' x ',I3,' to ',I3,I3)") narea-1,source(irecv),nxr,nyr,ides,jdes
4259!!$          WRITE (*,FMT="(I4,': test flag = ',I3)") narea-1, &
4260!!$                                  exch_flags(handle,irecv,indexr)
4261!!$#endif
4262!!$
4263!!$#ifdef PARALLEL_STATS
4264!!$          CALL MPI_test (exch_flags(handle,irecv,indexr),probe,status,ierr)
4265!!$          IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4266!!$          IF ( .NOT.probe ) THEN
4267!!$             nmwait = nmwait+1
4268!!$          ENDIF
4269!!$#endif /* PARALLEL_STATS */
4270!!$          CALL MPI_wait (exch_flags(handle,irecv,indexr),status,ierr)
4271!!$          IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4272!!$
4273!!$#ifdef PARALLEL_STATS
4274!!$          nmrecv = nmrecv + 1
4275!!$          nbrecv = nbrecv + kdim1*nbpw*nxr*nyr
4276!!$
4277!!$#endif /* PARALLEL_STATS */
4278!!$       ENDIF
4279!!$
4280!!$    ENDDO
4281!!$
4282!!$    ! Periodic boundary condition using internal copy.
4283!!$    ! This is performed after all data has been received so that we can
4284!!$    ! also copy boundary points and avoid some diagonal communication.
4285!!$
4286!!$    IF ( cyclic_bc .AND. jpni.EQ.1 ) THEN
4287!!$
4288!!$       IF ( enabled(Iplus) ) THEN
4289!!$          !ARPDBG        DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4290!!$!ARPDBG - broken? Loop over j is used as 3rd index in 3D arrays
4291!!$!ARPDBG   but kdim1 is correctly(?) set to extent of first dimension
4292!!$          DO j=1,jesub+jpreci
4293!!$             !ARPDBG           DO i=nhexch,1,-1
4294!!$             DO i=1,jpreci
4295!!$                IF ( PRESENT(b2) ) THEN
4296!!$                   !ARPDBG                 b2(iesub-i+1,j) = b2(i,j)
4297!!$                   b2(iesub+i,j) = b2(i,j)
4298!!$                ELSEIF ( PRESENT(ib2) ) THEN
4299!!$                   !ARPDBG                 ib2(iesub-i+1,j) = ib2(i,j)
4300!!$                   ib2(iesub+i,j) = ib2(i,j)
4301!!$                ELSEIF ( PRESENT(b3) ) THEN
4302!!$                   ! dir$           unroll
4303!!$                   DO k=1,kdim1
4304!!$                      !ARPDBG                    b3(k,iesub-i+1,j) = b3(k,i,j)
4305!!$                      b3(k,iesub+i,j) = b3(k,i,j)
4306!!$                   ENDDO
4307!!$                ELSEIF ( PRESENT(ib3) ) THEN
4308!!$                   ! dir$           unroll
4309!!$                   DO k=1,kdim1
4310!!$                      !ARPDBG                    ib3(k,iesub-i+1,j) = ib3(k,i,j)
4311!!$                      ib3(k,iesub+i,j) = ib3(k,i,j)
4312!!$                   ENDDO
4313!!$                ENDIF
4314!!$             ENDDO
4315!!$          ENDDO
4316!!$       ENDIF
4317!!$
4318!!$       IF ( enabled(Iminus) ) THEN
4319!!$          !ARPDBG        DO j=1,jesub,1
4320!!$          DO j=1,jesub+jpreci
4321!!$             DO i=1,jpreci
4322!!$                IF ( PRESENT(b2) ) THEN
4323!!$                   !ARPDBG                 b2(i,j) = b2(iesub-i+1,j)
4324!!$                   b2(1-i,j) = b2(iesub-i+1,j)
4325!!$                ELSEIF ( PRESENT(ib2) ) THEN
4326!!$                   !ARPDBG                 ib2(i,j) = ib2(iesub-i+1,j)
4327!!$                   ib2(1-i,j) = ib2(iesub-i+1,j)
4328!!$                ELSEIF ( PRESENT(b3) ) THEN
4329!!$                   ! dir$           unroll
4330!!$                   DO k=1,kdim1
4331!!$                      !ARPDBG                    b3(k,i,j) = b3(k,iesub-i+1,j)
4332!!$                      b3(1-i,j,k) = b3(iesub-i+1,j,k)
4333!!$                   ENDDO
4334!!$                ELSEIF ( PRESENT(ib3) ) THEN
4335!!$                   ! dir$           unroll
4336!!$                   DO k=1,kdim1
4337!!$                      !ARPDBG                    ib3(k,i,j) = ib3(k,iesub-i+1,j)
4338!!$                      ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4339!!$                   ENDDO
4340!!$                ENDIF
4341!!$             ENDDO
4342!!$          ENDDO
4343!!$       ENDIF
4344!!$
4345!!$    ENDIF
4346!!$
4347!!$    IF ( immed ) THEN
4348!!$
4349!!$       ! Check completion for immediate sends.
4350!!$
4351!!$       DO isend=1,nsend
4352!!$
4353!!$          IF (enabled(dirsend(isend)) .AND. &
4354!!$               destination(isend).GE.0 .AND. nxsend(isend,nhexch).GT.0 ) THEN
4355!!$
4356!!$             CALL MPI_wait (exch_flags(handle,isend,indexs),status,ierr)
4357!!$             IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4358!!$
4359!!$          ENDIF
4360!!$
4361!!$       ENDDO
4362!!$
4363!!$    ENDIF
4364!!$
4365!!$    ! Free the exchange communications handle.
4366!!$
4367!!$    CALL free_exch_handle(handle)
4368!!$
4369!!$  END SUBROUTINE exchr_generic
4370
4371  !=======================================================================
4372
4373  SUBROUTINE mpp_lbc_north_list(list, nfields)
4374    USE par_oce,     ONLY : jpni, jpi, jpj
4375    USE dom_oce,     ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
4376                            nwidthmax
4377    USE mapcomm_mod, ONLY : pielb, piesub
4378    USE lib_mpp,     ONLY : ctl_stop
4379    IMPLICIT none
4380    ! Subroutine arguments.
4381    TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
4382    INTEGER,                           INTENT(in) :: nfields 
4383
4384    !! * Local declarations
4385    INTEGER :: ijpj  ! No. of rows to operate upon
4386    INTEGER :: ii, ji, jj,  jk, jji, jjr, jr, jproc, klimit
4387    INTEGER :: ierr, ifield, ishifti, ishiftr
4388    INTEGER :: ildi,ilei,iilb
4389    INTEGER :: ij,ijt,iju, isgn
4390    INTEGER :: itaille
4391!FTRANS ztab :I :I :z
4392!FTRANS iztab :I :I :z
4393!FTRANS znorthgloio :I :I :z :
4394!FTRANS iznorthgloio :I :I :z :
4395!FTRANS znorthloc :I :I :z
4396!FTRANS iznorthloc :I :I :z
4397    INTEGER,  DIMENSION(:,:,:),   ALLOCATABLE, SAVE :: iztab
4398    INTEGER,  DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: iznorthgloio
4399    INTEGER,  DIMENSION(:,:,:),   ALLOCATABLE, SAVE :: iznorthloc
4400    REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE, SAVE :: ztab
4401    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio
4402    REAL(wp), DIMENSION(:,:,:),   ALLOCATABLE, SAVE :: znorthloc
4403    REAL(wp) :: psgn          ! control of the sign change
4404    LOGICAL :: field_is_real, fields_all_real, fields_all_int
4405    LOGICAL :: fields_all_3d, fields_all_2d
4406    !!----------------------------------------------------------------------
4407
4408    CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat)
4409
4410#if defined key_mpp_mpi
4411
4412    ! If we get into this routine it's because : North fold condition and mpp
4413    ! with more than one PE across i : we deal only with the North condition
4414
4415    ! Set no. of rows from a module parameter that is also used in exchtestmod
4416    ! and mpp_ini_north
4417    ijpj = num_nfold_rows
4418
4419    ! Allocate work-space arrays
4420    IF(.not. ALLOCATED(ztab))THEN
4421
4422       ALLOCATE(ztab(jpiglo,maxExchItems*ijpj,jpkorig),                 &
4423                iztab(jpiglo,maxExchItems*ijpj,jpkorig),                &
4424                znorthgloio(nwidthmax,maxExchItems*ijpj,jpkorig,jpni),  &
4425                znorthloc(nwidthmax,maxExchItems*ijpj,jpkorig),         &
4426                iznorthgloio(nwidthmax,maxExchItems*ijpj,jpkorig,jpni), &
4427                iznorthloc(nwidthmax,maxExchItems*ijpj,jpkorig),        &
4428                STAT=ierr)
4429       IF(ierr .ne. 0)THEN
4430          CALL ctl_stop('STOP','mpp_lbc_north_list: memory allocation failed')
4431          RETURN
4432       END IF
4433    END IF
4434
4435    ! put the last ijpj jlines of each real field into znorthloc
4436!    znorthloc(:,:,:)  = 0_wp ! because of padding for nwidthmax
4437!    iznorthloc(:,:,:) = 0
4438    ishiftr = 0
4439    ishifti = 0
4440    fields_all_real = .TRUE.
4441    fields_all_int  = .TRUE.
4442    fields_all_3d   = .TRUE.
4443    fields_all_2d   = .TRUE.
4444
4445    CALL prof_region_begin(NORTHLISTGATHER, "NorthListGather", iprofStat)
4446
4447    DO ifield=1,nfields,1
4448
4449       IF(ASSOCIATED(list(ifield)%r2dptr))THEN
4450          DO ij = 1, ijpj, 1
4451             jj = nlcj - ijpj + ij
4452             znorthloc(nldi:nlei,ij+ishiftr,1) = &
4453                                  list(ifield)%r2dptr(nldi:nlei,jj)
4454          END DO
4455
4456          ishiftr = ishiftr + ijpj
4457          fields_all_int = .FALSE.
4458          fields_all_3d  = .FALSE.
4459       ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
4460
4461#if defined key_z_first
4462          DO ij = 1, ijpj, 1
4463             jj = nlcj - ijpj + ij
4464             DO ii = nldi, nlei, 1
4465                DO jk = 1, jpk 
4466#else
4467          DO jk = 1, jpk 
4468             DO ij = 1, ijpj, 1
4469                jj = nlcj - ijpj + ij
4470                DO ii = nldi, nlei, 1
4471#endif
4472                   znorthloc(ii,ij+ishiftr,jk) = &
4473                                  list(ifield)%r3dptr(ii,jj,jk)
4474                END DO
4475             END DO
4476          END DO
4477
4478          ishiftr = ishiftr + ijpj
4479          fields_all_int = .FALSE.
4480          fields_all_2d  = .FALSE.
4481       ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
4482
4483          DO ij = 1, ijpj, 1
4484             jj = nlcj - ijpj + ij
4485             iznorthloc(nldi:nlei,ij+ishifti,1) = &
4486                                  list(ifield)%i2dptr(nldi:nlei,jj)
4487          END DO
4488
4489          ishifti = ishifti + ijpj
4490          fields_all_real = .FALSE.
4491          fields_all_3d   = .FALSE.
4492       ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
4493
4494#if defined key_z_first
4495          DO ij = 1, ijpj, 1
4496             jj = nlcj - ijpj + ij
4497             DO ii = nldi, nlei, 1
4498                DO jk = 1, jpk 
4499#else
4500          DO jk = 1, jpk 
4501             DO ij = 1, ijpj, 1
4502                jj = nlcj - ijpj + ij
4503                DO ii = nldi, nlei, 1
4504#endif
4505                   iznorthloc(ii,ij+ishifti,jk) = &
4506                                  list(ifield)%i3dptr(ii,jj,jk)
4507                END DO
4508             END DO
4509          END DO
4510
4511          ishifti = ishifti + ijpj
4512          fields_all_real = .FALSE.
4513          fields_all_2d   = .FALSE.
4514       END IF
4515
4516    END DO ! loop over fields
4517
4518    klimit = 1
4519    IF(.not. fields_all_2d)klimit = jpk
4520
4521    IF (npolj /= 0 ) THEN
4522       IF(.NOT. fields_all_int )THEN
4523          ! Build znorthgloio on proc 0 of ncomm_north
4524          !znorthgloio(:,:,:,:) = 0_wp
4525          itaille=nwidthmax*ishiftr*klimit
4526#if defined key_mpp_mpi
4527          CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, &
4528                          znorthgloio,itaille,MPI_DOUBLE_PRECISION,  &
4529                          0, ncomm_north, ierr)
4530#endif
4531       END IF
4532       IF(.NOT. fields_all_real )THEN
4533          ! Build iznorthgloio on proc 0 of ncomm_north
4534          !iznorthgloio(:,:,:,:) = 0
4535          itaille=nwidthmax*ishifti*klimit
4536#if defined key_mpp_mpi
4537          CALL MPI_GATHER(iznorthloc,itaille,MPI_INTEGER,  &
4538                          iznorthgloio,itaille,MPI_INTEGER,&
4539                          0, ncomm_north, ierr)
4540#endif
4541       END IF
4542    ENDIF
4543
4544    CALL prof_region_end(NORTHLISTGATHER, iprofStat)
4545
4546    CALL prof_region_begin(ARPNORTHAPPLYSYMM, "NorthListApplySymm", iprofStat)
4547
4548    IF (narea == north_root+1 ) THEN
4549       ! recover the global north array for every field
4550!       ztab(:,:,:) = 0_wp
4551!       iztab(:,:,:) = 0_wp
4552
4553       IF( .NOT. fields_all_int )THEN
4554
4555          DO jr = 1, ndim_rank_north
4556             jproc = nrank_north(jr) + 1
4557             ildi  = nldit (jproc)
4558             ilei  = nleit (jproc)
4559             iilb  = pielb(jproc)
4560             ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:jpk) = &
4561                  znorthgloio(ildi:ilei,1:ishiftr,1:jpk,jr)
4562          END DO
4563       END IF
4564       IF( .NOT. fields_all_real  )THEN
4565
4566          DO jr = 1, ndim_rank_north
4567             jproc = nrank_north(jr) + 1
4568             ildi  = nldit (jproc)
4569             ilei  = nleit (jproc)
4570             iilb  = pielb(jproc)
4571             iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:jpk) = &
4572                  iznorthgloio(ildi:ilei,1:ishifti,1:jpk,jr)
4573          END DO
4574       END IF
4575
4576       ! Horizontal slab
4577       ! ===============
4578
4579       jji = ijpj
4580       jjr = ijpj
4581
4582       ! 2. North-Fold boundary conditions
4583       ! ----------------------------------
4584
4585       SELECT CASE ( npolj )
4586
4587       CASE ( 3, 4 )                       ! *  North fold  T-point pivot
4588
4589          DO ifield=1, nfields, 1
4590
4591             ! Set-up stuff dependent on whether this field is real or integer
4592             field_is_real = .FALSE.
4593             IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4594                  ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
4595
4596             isgn = list(ifield)%isgn
4597             psgn = REAL(isgn, wp)
4598
4599             ! Set up stuff dependent on whether this field is 2- or 3-dimensional
4600             IF(fields_all_3d)THEN
4601                klimit=jpk
4602             ELSE IF(fields_all_2d)THEN
4603                klimit = 1
4604             ELSE
4605                IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4606                     ASSOCIATED(list(ifield)%i3dptr) )THEN
4607                   klimit=jpk
4608                ELSE
4609                   klimit = 1
4610                END IF
4611             END IF
4612
4613             IF(field_is_real)THEN
4614                ztab( 1    , jjr, 1:klimit) = 0._wp
4615                ztab(jpiglo, jjr, 1:klimit) = 0._wp
4616             ELSE
4617                iztab( 1    , jji, 1:klimit) = 0
4618                iztab(jpiglo, jji, 1:klimit) = 0               
4619             END IF
4620
4621             SELECT CASE ( list(ifield)%grid )
4622
4623             CASE ( 'T' , 'W' , 'S' )                         ! T-, W-point
4624
4625                IF(field_is_real)THEN
4626#if defined key_z_first
4627                   DO ji = 2, jpiglo/2
4628                      ijt = jpiglo-ji+2
4629                      DO jk = 1,klimit,1
4630                         ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4631                      END DO
4632                   END DO
4633                   DO ji = jpiglo/2+1, jpiglo
4634                      ijt = jpiglo-ji+2
4635                      DO jk = 1,klimit,1
4636                         ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4637                         ztab(ji,jjr,  jk) = psgn * ztab(ijt,jjr-2,jk)
4638                      END DO
4639                   END DO
4640#else
4641                   DO jk = 1,klimit,1
4642                      DO ji = 2, jpiglo/2
4643                         ijt = jpiglo-ji+2
4644                         ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4645                      END DO
4646                      DO ji = jpiglo/2+1, jpiglo
4647                         ijt = jpiglo-ji+2
4648                         ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4649                         ztab(ji,jjr,  jk) = psgn * ztab(ijt,jjr-2,jk)
4650                      END DO
4651                   END DO
4652#endif
4653                ELSE
4654#if defined key_z_first
4655                   DO ji = 2, jpiglo
4656                      ijt = jpiglo-ji+2
4657                      DO jk=1,klimit,1
4658                         iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4659                      END DO
4660                   END DO
4661                   DO ji = jpiglo/2+1, jpiglo
4662                      ijt = jpiglo-ji+2
4663                      DO jk=1,klimit,1
4664                         iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4665                      END DO
4666                   END DO
4667#else
4668                   DO jk=1,klimit,1
4669                      DO ji = 2, jpiglo
4670                         ijt = jpiglo-ji+2
4671                         iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4672                      END DO
4673                      DO ji = jpiglo/2+1, jpiglo
4674                         ijt = jpiglo-ji+2
4675                         iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4676                      END DO
4677                   END DO
4678#endif
4679                END IF
4680
4681             CASE ( 'U' )                                     ! U-point
4682
4683                IF(field_is_real)THEN
4684#if defined key_z_first
4685                   DO ji = 1, jpiglo-1
4686                      iju = jpiglo-ji+1
4687                      DO jk=1,klimit,1
4688                         ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk)
4689                      END DO
4690                   END DO
4691                   DO ji = jpiglo/2, jpiglo-1
4692                      iju = jpiglo-ji+1
4693                      DO jk=1,klimit,1
4694                         ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4695                      END DO
4696                   END DO
4697#else
4698                   DO jk=1,klimit,1
4699                      DO ji = 1, jpiglo-1
4700                         iju = jpiglo-ji+1
4701                         ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk)
4702                      END DO
4703                      DO ji = jpiglo/2, jpiglo-1
4704                         iju = jpiglo-ji+1
4705                         ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4706                      END DO
4707                   END DO
4708#endif
4709                ELSE
4710#if defined key_z_first
4711                   DO ji = 1, jpiglo-1
4712                      iju = jpiglo-ji+1
4713                      DO jk=1,klimit,1
4714                         iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk)
4715                      END DO
4716                   END DO
4717                   DO ji = jpiglo/2, jpiglo-1
4718                      iju = jpiglo-ji+1
4719                      DO jk=1,klimit,1
4720                         iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
4721                      END DO
4722                   END DO
4723#else
4724                   DO jk=1,klimit,1
4725                      DO ji = 1, jpiglo-1
4726                         iju = jpiglo-ji+1
4727                         iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk)
4728                      END DO
4729                      DO ji = jpiglo/2, jpiglo-1
4730                         iju = jpiglo-ji+1
4731                         iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
4732                      END DO
4733                   END DO
4734#endif
4735                END IF
4736
4737             CASE ( 'V' )                                     ! V-point
4738
4739                IF(field_is_real)THEN
4740#if defined key_z_first
4741                   DO ji = 2, jpiglo
4742                      ijt = jpiglo-ji+2
4743                      DO jk=1,klimit,1
4744#else
4745                   DO jk=1,klimit,1
4746                      DO ji = 2, jpiglo
4747                         ijt = jpiglo-ji+2
4748#endif
4749                         ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-2,jk)
4750                         ztab(ji,jjr  ,jk) = psgn * ztab(ijt,jjr-3,jk)
4751                      END DO
4752                   END DO
4753                ELSE
4754#if defined key_z_first
4755                   DO ji = 2, jpiglo
4756                      ijt = jpiglo-ji+2
4757                      DO jk=1,klimit,1
4758#else
4759                   DO jk=1,klimit,1
4760                      DO ji = 2, jpiglo
4761                         ijt = jpiglo-ji+2
4762#endif
4763                         iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-2,jk)
4764                         iztab(ji,jji  ,jk) = isgn * iztab(ijt,jji-3,jk)
4765                      END DO
4766                   END DO
4767                END IF
4768
4769             CASE ( 'F' , 'G' )                               ! F-point
4770
4771                IF(field_is_real)THEN
4772#if defined key_z_first
4773                   DO ji = 1, jpiglo-1
4774                      iju = jpiglo-ji+1
4775                      DO jk=1,klimit,1
4776#else
4777                   DO jk=1,klimit,1
4778                      DO ji = 1, jpiglo-1
4779                         iju = jpiglo-ji+1
4780#endif
4781                         ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-2,jk)
4782                         ztab(ji,jjr  ,jk) = psgn * ztab(iju,jjr-3,jk)
4783                      END DO
4784                   END DO
4785                ELSE
4786#if defined key_z_first
4787                   DO ji = 1, jpiglo-1
4788                      iju = jpiglo-ji+1
4789                      DO jk=1,klimit,1
4790#else
4791                   DO jk=1,klimit,1
4792                      DO ji = 1, jpiglo-1
4793                         iju = jpiglo-ji+1
4794#endif
4795                         iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-2,jk)
4796                         iztab(ji,jji  ,jk) = isgn * iztab(iju,jji-3,jk)
4797                      END DO
4798                   END DO
4799                END IF
4800
4801             CASE ( 'I' )                                    ! ice U-V point
4802
4803                IF(field_is_real)THEN
4804#if defined key_z_first
4805                   DO jk=1,klimit,1
4806                      ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk)
4807                   END DO
4808                   DO ji = 3, jpiglo
4809                      iju = jpiglo - ji + 3
4810                      DO jk=1,klimit,1
4811#else
4812                   DO jk=1,klimit,1
4813                      ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk)
4814                      DO ji = 3, jpiglo
4815                         iju = jpiglo - ji + 3
4816#endif
4817                         ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk)
4818                      END DO
4819                   END DO
4820                ELSE
4821#if defined key_z_first
4822                   DO jk=1,klimit,1
4823                      iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk)
4824                   END DO
4825                   DO ji = 3, jpiglo
4826                      iju = jpiglo - ji + 3
4827                      DO jk=1,klimit,1
4828#else
4829                   DO jk=1,klimit,1
4830                      iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk)
4831                      DO ji = 3, jpiglo
4832                         iju = jpiglo - ji + 3
4833#endif
4834                         iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk)
4835                      END DO
4836                   END DO
4837                END IF
4838
4839             END SELECT
4840
4841             ! Move to the next set of ijpj rows corresponding to the next field
4842             jjr = jjr + ijpj
4843             jji = jji + ijpj
4844
4845          END DO ! Loop over fields
4846
4847          CASE ( 5, 6 )                       ! *  North fold  F-point pivot
4848
4849             DO ifield=1, nfields, 1
4850
4851                ! Set-up stuff dependent on whether this field is real or integer
4852                field_is_real = .FALSE.
4853                IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4854                     ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
4855
4856                isgn = list(ifield)%isgn
4857                psgn=REAL(isgn, wp)
4858
4859                ! Set up stuff dependent on whether this field is 2- or 3-dimensional
4860                IF(fields_all_3d)THEN
4861                   klimit=jpk
4862                ELSE IF(fields_all_2d)THEN
4863                   klimit = 1
4864                ELSE
4865                   IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4866                        ASSOCIATED(list(ifield)%i3dptr) )THEN
4867                      klimit=jpk
4868                   ELSE
4869                      klimit = 1
4870                   END IF
4871                END IF
4872
4873                IF(field_is_real)THEN
4874                   DO jk = 1, klimit, 1
4875                      ztab( 1 ,jjr,jk)    = 0.0_wp
4876                      ztab(jpiglo,jjr,jk) = 0.0_wp
4877                   END DO
4878                ELSE
4879                   DO jk = 1, klimit, 1
4880                      iztab( 1 ,jji,jk)    = 0
4881                      iztab(jpiglo,jji,jk) = 0
4882                   END DO
4883                END IF
4884
4885                SELECT CASE ( list(ifield)%grid )
4886
4887                CASE ( 'T' , 'W' ,'S' )                          ! T-, W-point
4888
4889                   IF(field_is_real)THEN
4890#if defined key_z_first
4891                      DO ji = 1, jpiglo
4892                         ijt = jpiglo-ji+1
4893                         DO jk = 1,klimit,1
4894#else
4895                      DO jk = 1,klimit,1
4896                         DO ji = 1, jpiglo
4897                            ijt = jpiglo-ji+1
4898#endif
4899                            ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-1,jk)
4900                         END DO
4901                      END DO
4902                   ELSE
4903#if defined key_z_first
4904                      DO ji = 1, jpiglo
4905                         ijt = jpiglo-ji+1
4906                         DO jk=1,klimit,1
4907#else
4908                      DO jk=1,klimit,1
4909                         DO ji = 1, jpiglo
4910                            ijt = jpiglo-ji+1
4911#endif
4912                            iztab(ji,jji,jk) = isgn * iztab(ijt,jji-1,jk)
4913                         END DO
4914                      END DO
4915                   END IF
4916
4917                CASE ( 'U' )                                     ! U-point
4918
4919                   IF(field_is_real)THEN
4920#if defined key_z_first
4921                      DO ji = 1, jpiglo-1
4922                         iju = jpiglo-ji
4923                         DO jk=1,klimit,1
4924#else
4925                      DO jk=1,klimit,1
4926                         DO ji = 1, jpiglo-1
4927                            iju = jpiglo-ji
4928#endif
4929                            ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk)
4930                         END DO
4931                      END DO
4932                   ELSE
4933#if defined key_z_first
4934                      DO ji = 1, jpiglo-1
4935                         iju = jpiglo-ji
4936                         DO jk=1,klimit,1
4937#else
4938                      DO jk=1,klimit,1
4939                         DO ji = 1, jpiglo-1
4940                            iju = jpiglo-ji
4941#endif
4942                            iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk)
4943                         END DO
4944                      END DO
4945                   END IF
4946
4947                CASE ( 'V' )                                     ! V-point
4948                   IF(field_is_real)THEN
4949#if defined key_z_first
4950                      DO ji = 1, jpiglo
4951                         ijt = jpiglo-ji+1
4952                         DO jk=1,klimit,1
4953                            ztab(ji,jjr,jk)   = psgn * ztab(ijt,jjr-2,jk)
4954                         END DO
4955                      END DO
4956                      DO ji = jpiglo/2+1, jpiglo
4957                         ijt = jpiglo-ji+1
4958                         DO jk=1,klimit,1
4959                            ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4960                         END DO
4961                      END DO
4962#else
4963                      DO jk=1,klimit,1
4964                         DO ji = 1, jpiglo
4965                            ijt = jpiglo-ji+1
4966                            ztab(ji,jjr,jk)   = psgn * ztab(ijt,jjr-2,jk)
4967                         END DO
4968                         DO ji = jpiglo/2+1, jpiglo
4969                            ijt = jpiglo-ji+1
4970                            ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4971                         END DO
4972                      END DO
4973#endif
4974                   ELSE
4975#if defined key_z_first
4976                      DO ji = 1, jpiglo
4977                         ijt = jpiglo-ji+1
4978                         DO jk=1,klimit,1
4979                            iztab(ji,jji,jk)   = isgn * iztab(ijt,jji-2,jk)
4980                         END DO
4981                      END DO
4982                      DO ji = jpiglo/2+1, jpiglo
4983                         ijt = jpiglo-ji+1
4984                         DO jk=1,klimit,1
4985                            iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4986                         END DO
4987                      END DO
4988#else
4989                      DO jk=1,klimit,1
4990                         DO ji = 1, jpiglo
4991                            ijt = jpiglo-ji+1
4992                            iztab(ji,jji,jk)   = isgn * iztab(ijt,jji-2,jk)
4993                         END DO
4994                         DO ji = jpiglo/2+1, jpiglo
4995                            ijt = jpiglo-ji+1
4996                            iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4997                         END DO
4998                      END DO
4999#endif
5000                   END IF
5001
5002                CASE ( 'F' , 'G' )                               ! F-point
5003
5004                   IF(field_is_real)THEN
5005#if defined key_z_first
5006
5007                      DO ji = 1, jpiglo-1
5008                         iju = jpiglo-ji
5009                         DO jk=1,klimit,1
5010                            ztab(ji,jjr  ,jk) = psgn * ztab(iju,jjr-2,jk)
5011                         END DO
5012                      END DO
5013                      DO ji = jpiglo/2+1, jpiglo-1
5014                         iju = jpiglo-ji
5015                         DO jk=1,klimit,1
5016                            ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
5017                         END DO
5018                      END DO
5019#else
5020                      DO jk=1,klimit,1
5021                         DO ji = 1, jpiglo-1
5022                            iju = jpiglo-ji
5023                            ztab(ji,jjr  ,jk) = psgn * ztab(iju,jjr-2,jk)
5024                         END DO
5025                         DO ji = jpiglo/2+1, jpiglo-1
5026                            iju = jpiglo-ji
5027                            ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
5028                         END DO
5029                      END DO
5030#endif
5031                   ELSE
5032#if defined key_z_first
5033                      DO ji = 1, jpiglo-1
5034                         iju = jpiglo-ji
5035                         DO jk=1,klimit,1
5036                            iztab(ji,jji  ,jk) = isgn * iztab(iju,jji-2,jk)
5037                         END DO
5038                      END DO
5039                      DO ji = jpiglo/2+1, jpiglo-1
5040                         iju = jpiglo-ji
5041                         DO jk=1,klimit,1
5042                            iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
5043                         END DO
5044                      END DO
5045#else
5046                      DO jk=1,klimit,1
5047                         DO ji = 1, jpiglo-1
5048                            iju = jpiglo-ji
5049                            iztab(ji,jji  ,jk) = isgn * iztab(iju,jji-2,jk)
5050                         END DO
5051                         DO ji = jpiglo/2+1, jpiglo-1
5052                            iju = jpiglo-ji
5053                            iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
5054                         END DO
5055                      END DO
5056#endif
5057                   END IF
5058
5059                CASE ( 'I' )                                  ! ice U-V point
5060
5061                   IF(field_is_real)THEN
5062#if defined key_z_first
5063                      DO jk=1,klimit,1
5064                         ztab( 2 ,jjr,jk) = 0._wp
5065                      END DO
5066                      DO ji = 2 , jpiglo-1
5067                         ijt = jpiglo - ji + 2
5068                         DO jk=1,klimit,1
5069                            ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + &
5070                                 psgn * ztab(ijt,jjr-1,jk) )
5071                         END DO
5072                      END DO
5073#else
5074                      DO jk=1,klimit,1
5075                         ztab( 2 ,jjr,jk) = 0._wp
5076                         DO ji = 2 , jpiglo-1
5077                            ijt = jpiglo - ji + 2
5078                            ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + &
5079                                 psgn * ztab(ijt,jjr-1,jk) )
5080                         END DO
5081                      END DO
5082#endif
5083                   ELSE
5084#if defined key_z_first
5085                      DO jk=1,klimit,1
5086                         iztab( 2 ,jji,jk) = 0
5087                      END DO
5088                      DO ji = 2 , jpiglo-1
5089                         ijt = jpiglo - ji + 2
5090                         DO jk=1,klimit,1
5091                            iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + &
5092                                 isgn * iztab(ijt,jji-1,jk) )
5093                         END DO
5094                      END DO
5095#else
5096                      DO jk=1,klimit,1
5097                         iztab( 2 ,jji,jk) = 0
5098                         DO ji = 2 , jpiglo-1
5099                            ijt = jpiglo - ji + 2
5100                            iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + &
5101                                 isgn * iztab(ijt,jji-1,jk) )
5102                         END DO
5103                      END DO
5104#endif
5105                   END IF
5106
5107                END SELECT
5108
5109                ! Move to the next set of ijpj rows corresponding to the next field
5110                jjr = jjr + ijpj
5111                jji = jji + ijpj
5112             END DO ! loop over fields
5113
5114          CASE DEFAULT      ! *  closed : the code probably never go through
5115
5116             DO ifield=1, nfields, 1
5117
5118                ! Set-up stuff dependent on whether this field is real or integer
5119                field_is_real = .FALSE.
5120                IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
5121                     ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
5122
5123                ! Set up stuff dependent on whether this field is
5124                ! 2- or 3-dimensional
5125                IF(fields_all_3d)THEN
5126                   klimit=jpk
5127                ELSE IF(fields_all_2d)THEN
5128                   klimit = 1
5129                ELSE
5130                   IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
5131                        ASSOCIATED(list(ifield)%i3dptr) )THEN
5132                      klimit=jpk
5133                   ELSE
5134                      klimit = 1
5135                   END IF
5136                END IF
5137
5138                SELECT CASE ( list(ifield)%grid) 
5139
5140                CASE ( 'T' , 'U' , 'V' , 'W' )        ! T-, U-, V-, W-points
5141                   IF(field_is_real)THEN
5142#if defined key_z_first
5143                      DO ii = 1, jpiglo, 1
5144                         DO jk = 1, klimit, 1
5145#else
5146                      DO jk = 1, klimit, 1
5147                         DO ii = 1, jpiglo, 1
5148#endif
5149                            ztab(ii, 1 , jk) = 0_wp
5150                            ztab(ii,jjr, jk) = 0_wp
5151                         END DO
5152                      END DO
5153                   ELSE
5154#if defined key_z_first
5155                      DO ii = 1, jpiglo, 1
5156                         DO jk = 1, klimit, 1
5157#else
5158                      DO jk = 1, klimit, 1
5159                         DO ii = 1, jpiglo, 1
5160#endif
5161                            iztab(ii, 1 ,jk) = 0
5162                            iztab(ii,jji,jk) = 0
5163                          END DO
5164                      END DO
5165                  END IF
5166
5167                CASE ( 'F' )                          ! F-point
5168                   IF(field_is_real)THEN
5169                      ztab(:,jjr,1:klimit) = 0_wp
5170                   ELSE
5171                      iztab(:,jji,1:klimit) = 0
5172                   END IF
5173
5174                CASE ( 'I' )                          ! ice U-V point
5175                   IF(field_is_real)THEN
5176#if defined key_z_first
5177                      DO ii = 1, jpiglo, 1
5178                         DO jk = 1, klimit, 1
5179#else
5180                      DO jk = 1, klimit, 1
5181                         DO ii = 1, jpiglo, 1
5182#endif
5183                            ztab(ii, 1 ,jk) = 0_wp
5184                            ztab(ii,jjr,jk) = 0_wp
5185                         END DO
5186                      END DO
5187                   ELSE
5188#if defined key_z_first
5189                      DO ii = 1, jpiglo, 1
5190                         DO jk = 1, klimit, 1
5191#else
5192                      DO jk = 1, klimit, 1
5193                         DO ii = 1, jpiglo, 1
5194#endif
5195                            iztab(ii, 1 ,jk) = 0
5196                            iztab(ii,jji,jk) = 0
5197                         END DO
5198                      END DO
5199                   END IF
5200
5201                END SELECT
5202
5203                ! Move to the next set of ijpj rows corresponding to the next field
5204                jjr = jjr + ijpj
5205                jji = jji + ijpj
5206             END DO ! loop over fields
5207
5208          END SELECT
5209
5210
5211       !     End of slab
5212       !     ===========
5213
5214       !! Scatter back to original array(s)
5215!!$       DO jr = 1, ndim_rank_north
5216!!$          jproc=nrank_north(jr)+1
5217!!$          ildi=nldit (jproc)
5218!!$          ilei=nleit (jproc)
5219!!$          iilb=pielb(jproc)
5220!!$          IF(.NOT. fields_all_int)THEN
5221!!$             znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5222!!$                           ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5223!!$          END IF
5224!!$          IF(.NOT. fields_all_real)THEN
5225!!$             iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5226!!$                           iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5227!!$          END IF
5228!!$       END DO
5229
5230       IF(fields_all_int)THEN
5231
5232          DO jr = 1, ndim_rank_north
5233             jproc=nrank_north(jr)+1
5234             ildi=nldit (jproc)
5235             ilei=nleit (jproc)
5236             iilb=pielb(jproc)
5237! ARPDBG - make loop ordering explicit for performance?
5238             iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5239                     iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5240          END DO
5241
5242       ELSE IF(fields_all_real)THEN
5243
5244          DO jr = 1, ndim_rank_north
5245             jproc=nrank_north(jr)+1
5246             ildi=nldit (jproc)
5247             ilei=nleit (jproc)
5248             iilb=pielb(jproc)
5249! ARPDBG - make loop ordering explicit for performance?
5250             znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5251                     ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5252          END DO
5253
5254       ELSE ! Have some real and some integer fields
5255
5256          DO jr = 1, ndim_rank_north
5257             jproc=nrank_north(jr)+1
5258             ildi=nldit (jproc)
5259             ilei=nleit (jproc)
5260             iilb=pielb(jproc)
5261! ARPDBG - make loop ordering explicit for performance?
5262             znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5263                     ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5264             iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5265                     iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5266          END DO
5267
5268       END IF
5269
5270    ENDIF      ! only done on proc 0 of ncomm_north
5271
5272    CALL prof_region_end(ARPNORTHAPPLYSYMM, iprofStat)
5273
5274    CALL prof_region_begin(NORTHLISTSCATTER, "NorthListScatter", iprofStat)
5275
5276    IF ( npolj /= 0 ) THEN
5277       IF(.NOT. fields_all_int)THEN
5278          itaille=nwidthmax*ishiftr*klimit
5279          CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
5280                           znorthloc,  itaille,MPI_DOUBLE_PRECISION, &
5281                           0, ncomm_north,ierr)
5282       END IF
5283       IF(.NOT. fields_all_real)THEN
5284          itaille=nwidthmax*ishifti*klimit
5285          CALL MPI_SCATTER(iznorthgloio,itaille,MPI_INTEGER, &
5286                           iznorthloc,  itaille,MPI_INTEGER, &
5287                           0, ncomm_north,ierr)
5288
5289       END IF
5290    ENDIF
5291
5292    ! put back the last ijpj jlines of each field
5293    ishiftr = 0
5294    ishifti = 0
5295    DO ifield=1,nfields,1
5296
5297       IF(ASSOCIATED(list(ifield)%r2dptr))THEN
5298          DO ij = 1, ijpj, 1
5299             jj = nlcj - ijpj + ij
5300             list(ifield)%r2dptr(nldi:nlei,jj)= znorthloc(nldi:nlei,ij+ishiftr,1)
5301          END DO
5302          ishiftr = ishiftr + ijpj
5303       ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
5304#if defined key_z_first
5305          DO ij = 1, ijpj, 1
5306             jj = nlcj - ijpj + ij
5307             DO jk = 1, jpk 
5308#else
5309          DO jk = 1, jpk 
5310             DO ij = 1, ijpj, 1
5311                jj = nlcj - ijpj + ij
5312#endif
5313! ARPDBG Make loop over i explicit for performance?
5314                list(ifield)%r3dptr(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij+ishiftr,jk)
5315             END DO
5316          END DO
5317          ishiftr = ishiftr + ijpj
5318       ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
5319          DO ij = 1, ijpj, 1
5320             jj = nlcj - ijpj + ij
5321             list(ifield)%i2dptr(nldi:nlei,jj)= iznorthloc(nldi:nlei,ij+ishifti,1)
5322          END DO
5323          ishifti = ishifti + ijpj
5324       ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
5325#if defined key_z_first
5326          DO ij = 1, ijpj, 1
5327             jj = nlcj - ijpj + ij
5328             DO jk = 1, jpk 
5329#else
5330          DO jk = 1, jpk 
5331             DO ij = 1, ijpj, 1
5332                jj = nlcj - ijpj + ij
5333#endif
5334! ARPDBG Make loop over i explicit for performance?
5335                list(ifield)%i3dptr(nldi:nlei,jj,jk)= iznorthloc(nldi:nlei,ij+ishifti,jk)
5336             END DO
5337          END DO
5338          ishifti = ishifti + ijpj
5339       END IF
5340    END DO ! loop over fields
5341
5342    CALL prof_region_end(NORTHLISTSCATTER, iprofStat)
5343
5344#endif /* key_mpp_mpi */
5345
5346    CALL prof_region_end(ARPNORTHLISTCOMMS, iprofStat)
5347
5348  END SUBROUTINE mpp_lbc_north_list
5349
5350  !============================================================================
5351
5352  SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn)
5353    !!---------------------------------------------------------------------
5354    !!                   ***  routine mpp_lbc_north_2d  ***
5355    !!
5356    !! ** Purpose :
5357    !!      Ensure proper north fold horizontal bondary condition in mpp
5358    !!      configuration in case of jpn1 > 1 (for 2d array )
5359    !!
5360    !! ** Method :
5361    !!      Gather the 4 northern lines of the global domain on 1 processor and
5362    !!      apply lbc north-fold on this sub array. Then scatter the fold array
5363    !!      back to the processors.
5364    !!
5365    !! History :
5366    !!   8.5  !  03-09  (J.M. Molines ) For mpp folding condition at north
5367    !!                                  from lbc routine
5368    !!   9.0  !  03-12  (J.M. Molines ) encapsulation into lib_mpp, coding
5369    !!                                  rules of lbc_lnk
5370    !!----------------------------------------------------------------------
5371    USE par_oce,     ONLY : jpni, jpi, jpj
5372    USE dom_oce,     ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
5373                            nwidthmax
5374    USE mapcomm_mod, ONLY : pielb, piesub
5375    USE lib_mpp,     ONLY : ctl_stop
5376    USE arpdebugging, ONLY: dump_array
5377    IMPLICIT none
5378    !! * Arguments
5379    CHARACTER(len=1), INTENT( in ) ::   &
5380         cd_type       ! nature of pt2d grid-points
5381    !             !   = T ,  U , V , F or W  gridpoints
5382    REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   &
5383         pt2d          ! 2D array on which the boundary condition is applied
5384    REAL(wp), INTENT( in ) ::   &
5385         psgn          ! control of the sign change
5386    !             !   = -1. , the sign is changed if north fold boundary
5387    !             !   =  1. , the sign is kept  if north fold boundary
5388
5389    !! * Local declarations
5390
5391    INTEGER :: ijpj
5392    INTEGER :: ji, jj,  jr, jproc
5393    INTEGER :: ierr
5394    INTEGER :: ildi,ilei,iilb
5395    INTEGER :: ijpjm1,ij,ijt,iju
5396    INTEGER :: itaille
5397
5398    REAL(wp), DIMENSION(:,:),   ALLOCATABLE, SAVE :: ztab2
5399    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio2
5400    REAL(wp), DIMENSION(:,:),   ALLOCATABLE, SAVE :: znorthloc2
5401    !!----------------------------------------------------------------------
5402    !!  OPA 8.5, LODYC-IPSL (2002)
5403    !!----------------------------------------------------------------------
5404    ! If we get in this routine it's because : North fold condition and mpp
5405    ! with more than one PE across i : we deal only with the North condition
5406
5407    ! Set local from public PARAMETER
5408    ijpj = num_nfold_rows
5409
5410    CALL prof_region_begin(ARPNORTHCOMMS2D, "North2D", iprofStat)
5411
5412#if defined key_mpp_mpi
5413
5414    IF(.not. ALLOCATED(ztab2))THEN
5415
5416       ALLOCATE(ztab2(jpiglo,ijpj),                &
5417                znorthgloio2(nwidthmax,ijpj,ndim_rank_north), &
5418                znorthloc2(nwidthmax,ijpj),        &
5419                STAT=ierr)
5420       IF(ierr .ne. 0)THEN
5421          CALL ctl_stop('STOP','mpp_lbc_north_2d: memory allocation failed' )
5422       END IF
5423    END IF
5424
5425    ! 0. Sign setting
5426    ! ---------------
5427
5428    ijpjm1=ijpj-1
5429
5430    ! put the last ijpj jlines of pt2d into znorthloc2
5431    znorthloc2(:,:) = 0_wp ! because of padding for nwidthmax
5432
5433    ! jeub is the upper j limit of current domain in global coords
5434    !
5435    !                      |======================= jpjglo     ^
5436    !    <Trimmed>         |                                  /|\
5437    !                      |----------------------- jpjglo-1   |
5438    !                      |                                   |
5439    ! |---------jeub--------------------------------           
5440    ! |                    |                                   j
5441    ! |--------------------------------------------           
5442    ! |                    |                                   |
5443    ! |--------------------------------------------            |
5444    !
5445    ! No. of trimmed rows = jpjglo - jeub
5446    ! No. of valid rows for n-fold = ijpj - <no. trimmed rows>
5447    !                              = ijpj - jpjglo + jeub
5448    ! Need an iterator that ends with max value ijpj and has (ijpj-jpjglo+jeub)
5449    ! distinct values so start point must be:
5450    !  ij_start = ijpj - (ijpj-jpjglo+jeub) + 1 = jpjglo - jeub + 1
5451    ! => if jeub == jpjglo then we recover a starting value of 1.
5452    !    if jeub == jpjglo - 10 then ij_start = 11 so no loop iterations
5453    !    will be performed.
5454
5455#if defined NO_NFOLD_GATHER
5456    ! Post receives for other PE's north-fold data
5457    DO iproc = 1, ndim_rank_north, 1
5458
5459       IF( iproc-1 ==  nrank_north(iproc) ) CYCLE ! Skip this PE
5460
5461       CALL MPI_IRecv(znorthgloio2(), north_pts(iproc), MPI_DOUBLE_PRECISION, &
5462                      nrank_north(iproc), iproc, tag, ncomm_north,            &
5463                      nexch_flag(iproc) )
5464    END DO
5465#endif
5466
5467    DO ij = jpjglo - jeub + 1, ijpj, 1
5468
5469       jj = nlcj - ijpj + ij
5470       znorthloc2(nldi:nlei,ij)=pt2d(nldi:nlei,jj)
5471    END DO
5472
5473!    CALL dump_array(0,'znorthloc2',znorthloc2,withHalos=.TRUE.,toGlobal=.FALSE.)
5474
5475    IF (npolj /= 0 ) THEN
5476       ! Build in proc 0 of ncomm_north the znorthgloio2
5477       znorthgloio2(:,:,:) = 0_wp
5478       itaille=nwidthmax*ijpj
5479       CALL MPI_GATHER(znorthloc2,itaille,MPI_DOUBLE_PRECISION,    &
5480                       znorthgloio2,itaille,MPI_DOUBLE_PRECISION,  &
5481                       0, ncomm_north, ierr)
5482
5483    ENDIF
5484
5485    IF (narea == north_root+1 ) THEN
5486       ! recover the global north array
5487       ! ztab2 has full width of global domain
5488       ztab2(:,:) = 0_wp
5489
5490       DO jr = 1, ndim_rank_north
5491          jproc=nrank_north(jr)+1
5492          ildi=nldit(jproc)
5493          ilei=nleit(jproc)
5494          iilb=pielb(jproc)
5495          ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)= &
5496                               znorthgloio2(ildi:ilei,1:ijpj,jr)
5497       END DO
5498
5499!       CALL dump_array(0,'ztab2',ztab2,withHalos=.TRUE.,toGlobal=.FALSE.)
5500
5501       ! 2. North-Fold boundary conditions
5502       ! ----------------------------------
5503
5504       SELECT CASE ( npolj )
5505
5506       CASE ( 3, 4 )                       ! *  North fold  T-point pivot
5507
5508          ztab2( 1    ,ijpj) = 0._wp
5509          ztab2(jpiglo,ijpj) = 0._wp
5510
5511          SELECT CASE ( cd_type )
5512
5513          CASE ( 'T' , 'W' , 'S' )                         ! T-, W-point
5514             DO ji = 2, jpiglo
5515                ijt = jpiglo-ji+2
5516                ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2)
5517             END DO
5518             DO ji = jpiglo/2+1, jpiglo
5519                ijt = jpiglo-ji+2
5520                ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1)
5521             END DO
5522
5523          CASE ( 'U' )                                     ! U-point
5524             DO ji = 1, jpiglo-1
5525                iju = jpiglo-ji+1
5526                ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-2)
5527             END DO
5528             DO ji = jpiglo/2, jpiglo-1
5529                iju = jpiglo-ji+1
5530                ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1)
5531             END DO
5532
5533          CASE ( 'V' )                                     ! V-point
5534             DO ji = 2, jpiglo
5535                ijt = jpiglo-ji+2
5536                ztab2(ji,ijpj-1) = psgn * ztab2(ijt,ijpj-2)
5537                ztab2(ji,ijpj  ) = psgn * ztab2(ijt,ijpj-3)
5538             END DO
5539
5540          CASE ( 'F' , 'G' )                               ! F-point
5541             DO ji = 1, jpiglo-1
5542                iju = jpiglo-ji+1
5543                ztab2(ji,ijpj-1) = psgn * ztab2(iju,ijpj-2)
5544                ztab2(ji,ijpj  ) = psgn * ztab2(iju,ijpj-3)
5545             END DO
5546
5547          CASE ( 'I' )                                     ! ice U-V point
5548             ztab2(2,ijpj) = psgn * ztab2(3,ijpj-1)
5549             DO ji = 3, jpiglo
5550                iju = jpiglo - ji + 3
5551                ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1)
5552             END DO
5553
5554          END SELECT
5555
5556       CASE ( 5, 6 )                        ! *  North fold  F-point pivot
5557
5558          ztab2( 1 ,ijpj) = 0._wp
5559          ztab2(jpiglo,ijpj) = 0._wp
5560
5561          SELECT CASE ( cd_type )
5562
5563          CASE ( 'T' , 'W' ,'S' )                          ! T-, W-point
5564             DO ji = 1, jpiglo
5565                ijt = jpiglo-ji+1
5566                ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-1)
5567             END DO
5568
5569          CASE ( 'U' )                                     ! U-point
5570             DO ji = 1, jpiglo-1
5571                iju = jpiglo-ji
5572                ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1)
5573             END DO
5574
5575          CASE ( 'V' )                                     ! V-point
5576             DO ji = 1, jpiglo
5577                ijt = jpiglo-ji+1
5578                ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2)
5579             END DO
5580             DO ji = jpiglo/2+1, jpiglo
5581                ijt = jpiglo-ji+1
5582                ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1)
5583             END DO
5584
5585          CASE ( 'F' , 'G' )                               ! F-point
5586             DO ji = 1, jpiglo-1
5587                iju = jpiglo-ji
5588                ztab2(ji,ijpj  ) = psgn * ztab2(iju,ijpj-2)
5589             END DO
5590             DO ji = jpiglo/2+1, jpiglo-1
5591                iju = jpiglo-ji
5592                ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1)
5593             END DO
5594
5595             CASE ( 'I' )                                  ! ice U-V point
5596                ztab2( 2 ,ijpj) = 0.e0
5597                DO ji = 2 , jpiglo-1
5598                   ijt = jpiglo - ji + 2
5599                   ztab2(ji,ijpj)= 0.5 * ( ztab2(ji,ijpj-1) + psgn * ztab2(ijt,ijpj-1) )
5600                END DO
5601
5602          END SELECT
5603
5604       CASE DEFAULT                           ! *  closed : the code probably never go through
5605
5606            SELECT CASE ( cd_type) 
5607 
5608            CASE ( 'T' , 'U' , 'V' , 'W' )        ! T-, U-, V-, W-points
5609               ztab2(:, 1 ) = 0._wp
5610               ztab2(:,ijpj) = 0._wp
5611
5612            CASE ( 'F' )                          ! F-point
5613               ztab2(:,ijpj) = 0._wp
5614
5615            CASE ( 'I' )                          ! ice U-V point
5616               ztab2(:, 1 ) = 0._wp
5617               ztab2(:,ijpj) = 0._wp
5618
5619            END SELECT
5620
5621         END SELECT
5622
5623         !     End of slab
5624         !     ===========
5625
5626         !! Scatter back to pt2d
5627         DO jr = 1, ndim_rank_north
5628            jproc=nrank_north(jr)+1
5629            ildi=nldit (jproc)
5630            ilei=nleit (jproc)
5631            iilb=pielb(jproc)
5632            znorthgloio2(ildi:ilei,1:ijpj,jr)= &
5633                             ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
5634         END DO
5635
5636      ENDIF      ! only done on proc 0 of ncomm_north
5637
5638      IF ( npolj /= 0 ) THEN
5639         itaille=nwidthmax*ijpj
5640         CALL MPI_SCATTER(znorthgloio2,itaille,MPI_DOUBLE_PRECISION, &
5641                          znorthloc2,  itaille,MPI_DOUBLE_PRECISION, &
5642                          0,ncomm_north,ierr)
5643      ENDIF
5644
5645      ! Put the last ijpj jlines of pt2d into znorthloc2 while allowing
5646      ! for any trimming of domain (see earlier comments and diagram)
5647      DO ij = jpjglo - jeub + 1, ijpj, 1
5648         jj = nlcj - ijpj + ij
5649         pt2d(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
5650      END DO
5651
5652#endif /* key_mpp_mpi */
5653
5654      CALL prof_region_end(ARPNORTHCOMMS2D, iprofStat)
5655
5656   END SUBROUTINE mpp_lbc_north_2d
5657
5658   !====================================================================
5659
5660   SUBROUTINE mpp_lbc_north_i2d ( ib2, cd_type, isgn)
5661    !!---------------------------------------------------------------------
5662    !!                   ***  routine mpp_lbc_north_2d  ***
5663    !!
5664    !! ** Purpose :
5665    !!      Ensure proper north fold horizontal bondary condition in mpp
5666    !!      configuration in case of jpn1 > 1 (for 2d array )
5667    !!
5668    !! ** Method :
5669    !!      Gather the 4 northern lines of the global domain on 1 processor and
5670    !!      apply lbc north-fold on this sub array. Then scatter the fold array
5671    !!      back to the processors.
5672    !!
5673    !! History :
5674    !!   8.5  !  03-09  (J.M. Molines ) For mpp folding condition at north
5675    !!                                  from lbc routine
5676    !!   9.0  !  03-12  (J.M. Molines ) encapsulation into lib_mpp,
5677    !!                  coding rules of lbc_lnk
5678    !!----------------------------------------------------------------------
5679    USE par_oce, ONLY : jpni, jpi, jpj
5680    USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, &
5681                        nlcj, nwidthmax
5682    USE mapcomm_mod,    ONLY : pielb, piesub
5683    USE lib_mpp, ONLY : ctl_stop
5684    IMPLICIT none
5685    !! * Arguments
5686    CHARACTER(len=1), INTENT( in ) ::   &
5687         cd_type       ! nature of ib2 grid-points
5688    !             !   = T ,  U , V , F or W  gridpoints
5689    INTEGER, DIMENSION(jpi,jpj), INTENT( inout ) ::   &
5690         ib2          ! 2D array on which the boundary condition is applied
5691    INTEGER, INTENT( in ) ::   &
5692         isgn     ! control of the sign change
5693    !             !   = -1. , the sign is changed if north fold boundary
5694    !             !   =  1. , the sign is kept  if north fold boundary
5695
5696    !! * Local declarations
5697
5698    INTEGER :: ijpj
5699    INTEGER :: ji, jj,  jr, jproc
5700    INTEGER :: ierr
5701    INTEGER :: ildi,ilei,iilb
5702    INTEGER :: ijpjm1,ij,ijt,iju
5703    INTEGER :: itaille
5704
5705    INTEGER, DIMENSION(:,:),   ALLOCATABLE :: ztab2
5706    INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio2
5707    INTEGER, DIMENSION(:,:),   ALLOCATABLE :: znorthloc2
5708    !!----------------------------------------------------------------------
5709    !!  OPA 8.5, LODYC-IPSL (2002)
5710    !!----------------------------------------------------------------------
5711    ! If we get in this routine it's because : North fold condition and mpp
5712    ! with more than one PE across i : we deal only with the North condition
5713
5714#if defined key_mpp_mpi
5715
5716    ijpj = num_nfold_rows
5717    ijpjm1=ijpj - 1
5718
5719
5720     IF(.not. ALLOCATED(ztab2))THEN
5721
5722        ALLOCATE(ztab2(jpiglo,ijpj),                &
5723                 znorthgloio2(nwidthmax,ijpj,jpni), &
5724                 znorthloc2(nwidthmax,ijpj),        &
5725                 STAT=ierr)
5726        IF(ierr .ne. 0)THEN
5727           CALL ctl_stop('STOP','mpp_lbc_north_i2d: memory allocation failed')
5728        END IF
5729     END IF
5730
5731    ! 0. Sign setting
5732    ! ---------------
5733
5734    ! Put the last ijpj jlines of ib2 into znorthloc2 while allowing
5735    ! for any trimming of domain (see earlier comments and diagram in
5736    ! mpp_lbc_north_2d).
5737    znorthloc2(:,:) = 0  ! because of padding for nwidthmax
5738    DO ij = jpjglo - jeub + 1, ijpj, 1
5739       jj = nlcj - ijpj + ij
5740       znorthloc2(nldi:nlei,ij)=ib2(nldi:nlei,jj)
5741    END DO
5742
5743    IF (npolj /= 0 ) THEN
5744       ! Build in proc 0 of ncomm_north the znorthgloio2
5745       znorthgloio2(:,:,:) = 0
5746       itaille=nwidthmax*ijpj
5747       CALL MPI_GATHER(znorthloc2,itaille,MPI_INTEGER,    &
5748                       znorthgloio2,itaille,MPI_INTEGER,0,&
5749                       ncomm_north,ierr)
5750    ENDIF
5751
5752    IF (narea == north_root+1 ) THEN
5753       ! recover the global north array
5754       ztab2(:,:) = 0
5755
5756       DO jr = 1, ndim_rank_north
5757          jproc=nrank_north(jr)+1
5758          ildi=nldit (jproc)
5759          ilei=nleit (jproc)
5760          iilb=pielb(jproc)
5761          !WRITE (*,*)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',&
5762          !            ildi, ilei, iilb, ijpj
5763          ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) = &
5764                                     znorthgloio2(ildi:ilei,1:ijpj,jr)
5765       END DO
5766
5767
5768       ! 2. North-Fold boundary conditions
5769       ! ----------------------------------
5770
5771       SELECT CASE ( npolj )
5772
5773       CASE ( 3, 4 )                       ! *  North fold  T-point pivot
5774
5775          ztab2( 1    ,ijpj) = 0
5776          ztab2(jpiglo,ijpj) = 0
5777
5778          SELECT CASE ( cd_type )
5779
5780          CASE ( 'T' , 'W' , 'S' )                         ! T-, W-point
5781             DO ji = 2, jpiglo
5782                ijt = jpiglo-ji+2
5783                ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2)
5784             END DO
5785             DO ji = jpiglo/2+1, jpiglo
5786                ijt = jpiglo-ji+2
5787                ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1)
5788             END DO
5789
5790          CASE ( 'U' )                                     ! U-point
5791             DO ji = 1, jpiglo-1
5792                iju = jpiglo-ji+1
5793                ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-2)
5794             END DO
5795             DO ji = jpiglo/2, jpiglo-1
5796                iju = jpiglo-ji+1
5797                ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1)
5798             END DO
5799
5800          CASE ( 'V' )                                     ! V-point
5801             DO ji = 2, jpiglo
5802                ijt = jpiglo-ji+2
5803                ztab2(ji,ijpj-1) = isgn * ztab2(ijt,ijpj-2)
5804                ztab2(ji,ijpj  ) = isgn * ztab2(ijt,ijpj-3)
5805             END DO
5806
5807          CASE ( 'F' , 'G' )                               ! F-point
5808             DO ji = 1, jpiglo-1
5809                iju = jpiglo-ji+1
5810                ztab2(ji,ijpj-1) = isgn * ztab2(iju,ijpj-2)
5811                ztab2(ji,ijpj  ) = isgn * ztab2(iju,ijpj-3)
5812             END DO
5813
5814          CASE ( 'I' )                                     ! ice U-V point
5815             ztab2(2,ijpj) = isgn * ztab2(3,ijpj-1)
5816             DO ji = 3, jpiglo
5817                iju = jpiglo - ji + 3
5818                ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1)
5819             END DO
5820
5821          END SELECT
5822
5823       CASE ( 5, 6 )                        ! *  North fold  F-point pivot
5824
5825          ztab2( 1 ,ijpj) = 0
5826          ztab2(jpiglo,ijpj) = 0
5827
5828          SELECT CASE ( cd_type )
5829
5830          CASE ( 'T' , 'W' ,'S' )                          ! T-, W-point
5831             DO ji = 1, jpiglo
5832                ijt = jpiglo-ji+1
5833                ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-1)
5834             END DO
5835
5836          CASE ( 'U' )                                     ! U-point
5837             DO ji = 1, jpiglo-1
5838                iju = jpiglo-ji
5839                ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1)
5840             END DO
5841
5842          CASE ( 'V' )                                     ! V-point
5843             DO ji = 1, jpiglo
5844                ijt = jpiglo-ji+1
5845                ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2)
5846             END DO
5847             DO ji = jpiglo/2+1, jpiglo
5848                ijt = jpiglo-ji+1
5849                ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1)
5850             END DO
5851
5852          CASE ( 'F' , 'G' )                               ! F-point
5853             DO ji = 1, jpiglo-1
5854                iju = jpiglo-ji
5855                ztab2(ji,ijpj  ) = isgn * ztab2(iju,ijpj-2)
5856             END DO
5857             DO ji = jpiglo/2+1, jpiglo-1
5858                iju = jpiglo-ji
5859                ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1)
5860             END DO
5861
5862             CASE ( 'I' )                                  ! ice U-V point
5863                ztab2( 2 ,ijpj) = 0
5864                DO ji = 2 , jpiglo-1
5865                   ijt = jpiglo - ji + 2
5866                   ztab2(ji,ijpj)= NINT(0.5 * ( ztab2(ji,ijpj-1) + &
5867                                       isgn * ztab2(ijt,ijpj-1) ))
5868                END DO
5869
5870          END SELECT
5871
5872       CASE DEFAULT         ! *  closed : the code probably never go through
5873
5874            SELECT CASE ( cd_type) 
5875 
5876            CASE ( 'T' , 'U' , 'V' , 'W' )        ! T-, U-, V-, W-points
5877               ztab2(:, 1 ) = 0
5878               ztab2(:,ijpj) = 0
5879
5880            CASE ( 'F' )                          ! F-point
5881               ztab2(:,ijpj) = 0
5882
5883            CASE ( 'I' )                          ! ice U-V point
5884               ztab2(:, 1 ) = 0
5885               ztab2(:,ijpj) = 0
5886
5887            END SELECT
5888
5889         END SELECT
5890
5891         !     End of slab
5892         !     ===========
5893
5894         !! Scatter back to ib2
5895         DO jr = 1, ndim_rank_north
5896            jproc=nrank_north(jr)+1
5897            ildi=nldit (jproc)
5898            ilei=nleit (jproc)
5899            iilb=pielb(jproc)
5900            znorthgloio2(ildi:ilei,1:ijpj,jr) = &
5901                                ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
5902         END DO
5903
5904      ENDIF      ! only done on proc 0 of ncomm_north
5905
5906      IF ( npolj /= 0 ) THEN
5907         itaille=nwidthmax*ijpj
5908         CALL MPI_SCATTER(znorthgloio2,itaille,MPI_INTEGER, &
5909                          znorthloc2,  itaille,MPI_INTEGER, &
5910                          0, ncomm_north, ierr)
5911      ENDIF
5912
5913      ! put in the last ijpj jlines of ib2 from znorthloc2 while allowing
5914      ! for any trimming of domain (see earlier comments and diagram in
5915      ! mpp_lbc_north_2d).
5916      DO ij = jpjglo - jeub + 1, ijpj, 1
5917         jj = nlcj - ijpj + ij
5918         ib2(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
5919      END DO
5920      WRITE(*,*) 'ARPDBG: finished in mpp_lbc_north_i2d'
5921
5922#endif /* key_mpp_mpi */
5923
5924   END SUBROUTINE mpp_lbc_north_i2d
5925
5926   !=================================================================
5927
5928   SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
5929     !!---------------------------------------------------------------------
5930     !!                   ***  routine mpp_lbc_north_3d  ***
5931     !!
5932     !! ** Purpose :
5933     !!      Ensure proper north fold horizontal bondary condition in mpp
5934     !!      configuration in case of jpn1 > 1
5935     !!
5936     !! ** Method :
5937     !!      Gather the 4 northern lines of the global domain on 1 processor
5938     !!      and apply lbc north-fold on this sub array. Then scatter the
5939     !!      fold array back to the processors.
5940     !!
5941     !! History :
5942     !!   8.5  !  03-09  (J.M. Molines ) For mpp folding condition at north
5943     !!                                  from lbc routine
5944     !!   9.0  !  03-12  (J.M. Molines ) encapsulation into lib_mpp,
5945     !!                                  coding rules of lbc_lnk
5946     !!----------------------------------------------------------------------
5947     USE par_oce, ONLY : jpni
5948     USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, nwidthmax
5949     USE mapcomm_mod,    ONLY : pielb, piesub
5950     USE lib_mpp, ONLY : ctl_stop
5951     IMPLICIT none
5952     !! * Arguments
5953     CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points
5954     !                                         ! = T,  U, V, F or W gridp'ts
5955     REAL(wp), DIMENSION(:,:,:), INTENT( inout ) ::   &
5956          pt3d          ! 3D array on which the boundary condition is applied
5957     REAL(wp), INTENT( in ) ::   &
5958          psgn          ! control of the sign change
5959     !                  !   = -1. , the sign is changed if north fold boundary
5960     !                  !   =  1. , the sign is kept  if north fold boundary
5961
5962     !! * Local declarations
5963     INTEGER :: ijpj
5964     INTEGER :: ji, jj, jk, jr, jproc
5965     INTEGER :: ierr
5966     INTEGER :: ildi,ilei,iilb
5967     INTEGER :: ijpjm1,ij,ijt,iju
5968     INTEGER :: itaille
5969!FTRANS ztab :I :I :z
5970!FTRANS znorthgloio :I :I :z :
5971!FTRANS znorthloc :I :I :z
5972     REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE :: ztab
5973     REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
5974     REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE :: znorthloc
5975     !!----------------------------------------------------------------------
5976
5977     ! If we get in this routine it's because : North fold condition and
5978     ! mpp with more than one proc across i : we deal only with the North
5979     ! condition
5980#if defined key_mpp_mpi
5981
5982     ijpj = num_nfold_rows
5983     ijpjm1=ijpj - 1
5984
5985     IF(.not. ALLOCATED(ztab))THEN
5986
5987        ALLOCATE(ztab(jpiglo,ijpj,jpkorig),                &
5988                 znorthgloio(nwidthmax,ijpj,jpkorig,jpni), &
5989                 znorthloc(nwidthmax,ijpj,jpkorig),        &
5990                 STAT=ierr)
5991        IF(ierr .ne. 0)THEN
5992           CALL ctl_stop( ' mpp_lbc_north_3d: memory allocation failed' )
5993#if defined key_mpp_mpi
5994           CALL mpi_finalize( ierr )
5995#endif
5996           STOP
5997        END IF
5998     END IF
5999
6000    CALL prof_region_begin(NORTH3DGATHER, "North3DGather", iprofStat)
6001
6002     ! 0. Sign setting
6003     ! ---------------
6004
6005    ! Put the last ijpj jlines of pt3d into znorthloc while allowing
6006    ! for any trimming of domain (see earlier comments and diagram in
6007    ! mpp_lbc_north_2d).
6008    ! Have to initialise all to zero in case chunks are missing due to domain
6009    ! trimming
6010    znorthloc(:,:,:) = 0.0_wp
6011#if defined key_z_first
6012    DO ij = jpjglo - jeub + 1, ijpj, 1
6013       jj = nlcj - ijpj + ij
6014       DO jk = 1, jpk 
6015#else
6016    DO jk = 1, jpk 
6017       DO ij = jpjglo - jeub + 1, ijpj, 1
6018          jj = nlcj - ijpj + ij
6019#endif
6020          znorthloc(nldi:nlei,ij,jk) = pt3d(nldi:nlei,jj,jk)
6021       END DO
6022    END DO
6023
6024
6025    IF (npolj /= 0 ) THEN
6026       ! Build in proc 0 of ncomm_north the znorthgloio
6027
6028#ifdef key_mpp_shmem
6029       not done : compiler error
6030#elif defined key_mpp_mpi
6031       itaille=nwidthmax*jpkorig*ijpj
6032       CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,   &
6033                       znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
6034                       0,ncomm_north,ierr)
6035#endif
6036
6037    ENDIF
6038
6039    CALL prof_region_end(NORTH3DGATHER, iprofStat)
6040
6041    CALL prof_region_begin(NORTH3DAPPSYMM, "North3DApplySymm", iprofStat)
6042
6043    IF (narea == north_root+1 ) THEN
6044       ! recover the global north array
6045       ztab(:,:,:) = 0_wp
6046
6047       DO jr = 1, ndim_rank_north
6048          jproc = nrank_north(jr) + 1
6049          ildi  = nldit (jproc)
6050          ilei  = nleit (jproc)
6051          iilb  = pielb(jproc)
6052          ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = &
6053                                          znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr)
6054       END DO
6055
6056
6057       ! Horizontal slab
6058       ! ===============
6059#if defined key_z_first
6060
6061       ! 2. North-Fold boundary conditions
6062       ! ----------------------------------
6063
6064       SELECT CASE ( npolj )
6065
6066       CASE ( 3, 4 )                       ! *  North fold  T-point pivot
6067
6068          DO jk = 1, jpk 
6069             ztab( 1    ,ijpj,jk) = 0.0_wp
6070             ztab(jpiglo,ijpj,jk) = 0.0_wp
6071          END DO
6072
6073          SELECT CASE ( cd_type )
6074
6075          CASE ( 'T' , 'S' , 'W' )                   ! T-, W-point
6076             DO ji = 2, jpiglo
6077                ijt = jpiglo-ji+2
6078                DO jk = 1, jpk 
6079                   ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6080                END DO
6081             END DO
6082             DO ji = jpiglo/2+1, jpiglo
6083                ijt = jpiglo-ji+2
6084                DO jk = 1, jpk, 1
6085                   ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6086                END DO
6087             END DO
6088
6089          CASE ( 'U' )                               ! U-point
6090             DO ji = 1, jpiglo-1
6091                iju = jpiglo-ji+1
6092                DO jk = 1, jpk, 1
6093                   ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
6094                END DO
6095             END DO
6096             DO ji = jpiglo/2, jpiglo-1
6097                iju = jpiglo-ji+1
6098                DO jk = 1, jpk, 1
6099                   ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6100                END DO
6101             END DO
6102
6103          CASE ( 'V' )                               ! V-point
6104             DO ji = 2, jpiglo
6105                ijt = jpiglo-ji+2
6106                DO jk = 1, jpk, 1
6107                   ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
6108                   ztab(ji,ijpj  ,jk) = psgn * ztab(ijt,ijpj-3,jk)
6109                END DO
6110             END DO
6111
6112          CASE ( 'F' , 'G' )                         ! F-point
6113             DO ji = 1, jpiglo-1
6114                iju = jpiglo-ji+1
6115                DO jk = 1, jpk, 1
6116                   ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
6117                   ztab(ji,ijpj  ,jk) = psgn * ztab(iju,ijpj-3,jk)
6118                END DO
6119             END DO
6120
6121          END SELECT
6122
6123       CASE ( 5, 6 )                        ! *  North fold  F-point pivot
6124
6125          DO jk = 1, jpk, 1
6126             ztab( 1    ,ijpj,jk) = 0._wp
6127             ztab(jpiglo,ijpj,jk) = 0._wp
6128          END DO
6129
6130          SELECT CASE ( cd_type )
6131
6132          CASE ( 'T' , 'S' , 'W' )                   ! T-, W-point
6133             DO ji = 1, jpiglo
6134                ijt = jpiglo-ji+1
6135                DO jk = 1, jpk, 1
6136                   ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
6137                END DO
6138             END DO
6139
6140          CASE ( 'U' )                               ! U-point
6141             DO ji = 1, jpiglo-1
6142                iju = jpiglo-ji
6143                DO jk = 1, jpk, 1
6144                   ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
6145                END DO
6146             END DO
6147
6148          CASE ( 'V' )                               ! V-point
6149             DO ji = 1, jpiglo
6150                ijt = jpiglo-ji+1
6151                DO jk = 1, jpk, 1
6152                   ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6153                END DO
6154             END DO
6155             DO ji = jpiglo/2+1, jpiglo
6156                ijt = jpiglo-ji+1
6157                DO jk = 1, jpk, 1
6158                   ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6159                END DO
6160             END DO
6161
6162          CASE ( 'F' , 'G' )                         ! F-point
6163             DO ji = 1, jpiglo-1
6164                iju = jpiglo-ji
6165                DO jk = 1, jpk, 1
6166                   ztab(ji,ijpj  ,jk) = psgn * ztab(iju,ijpj-2,jk)
6167                END DO
6168             END DO
6169             DO ji = jpiglo/2+1, jpiglo-1
6170                iju = jpiglo-ji
6171                DO jk = 1, jpk, 1
6172                   ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6173                END DO
6174             END DO
6175
6176          END SELECT
6177
6178       CASE DEFAULT                           ! *  closed
6179
6180          SELECT CASE ( cd_type) 
6181
6182          CASE ( 'T' , 'U' , 'V' , 'W' )      ! T-, U-, V-, W-points
6183             DO ji = 1, jpiglo, 1
6184                DO jk = 1, jpk, 1
6185                   ztab(ji, 1  ,jk) = 0.0_wp
6186                   ztab(ji,ijpj,jk) = 0.0_wp
6187                END DO
6188             END DO
6189
6190          CASE ( 'F' )                        ! F-point
6191             DO ji = 1, jpiglo, 1
6192                DO jk = 1, jpk, 1
6193                   ztab(ji,ijpj,jk) = 0.0_wp
6194                END DO
6195             END DO
6196
6197          END SELECT
6198
6199       END SELECT
6200
6201       !     End of slab
6202       !     ===========
6203#else
6204       DO jk = 1, jpk 
6205
6206
6207          ! 2. North-Fold boundary conditions
6208          ! ----------------------------------
6209
6210          SELECT CASE ( npolj )
6211
6212          CASE ( 3, 4 )                       ! *  North fold  T-point pivot
6213
6214             ztab( 1    ,ijpj,jk) = 0.0_wp
6215             ztab(jpiglo,ijpj,jk) = 0.0_wp
6216
6217             SELECT CASE ( cd_type )
6218
6219             CASE ( 'T' , 'S' , 'W' )                   ! T-, W-point
6220                DO ji = 2, jpiglo
6221                   ijt = jpiglo-ji+2
6222                   ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6223                END DO
6224                DO ji = jpiglo/2+1, jpiglo
6225                   ijt = jpiglo-ji+2
6226                   ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6227                END DO
6228
6229             CASE ( 'U' )                               ! U-point
6230                DO ji = 1, jpiglo-1
6231                   iju = jpiglo-ji+1
6232                   ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
6233                END DO
6234                DO ji = jpiglo/2, jpiglo-1
6235                   iju = jpiglo-ji+1
6236                   ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6237                END DO
6238
6239             CASE ( 'V' )                               ! V-point
6240                DO ji = 2, jpiglo
6241                   ijt = jpiglo-ji+2
6242                   ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
6243                   ztab(ji,ijpj  ,jk) = psgn * ztab(ijt,ijpj-3,jk)
6244                END DO
6245
6246             CASE ( 'F' , 'G' )                         ! F-point
6247                DO ji = 1, jpiglo-1
6248                   iju = jpiglo-ji+1
6249                   ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
6250                   ztab(ji,ijpj  ,jk) = psgn * ztab(iju,ijpj-3,jk)
6251                END DO
6252
6253             END SELECT
6254
6255          CASE ( 5, 6 )                        ! *  North fold  F-point pivot
6256
6257             ztab( 1    ,ijpj,jk) = 0._wp
6258             ztab(jpiglo,ijpj,jk) = 0._wp
6259
6260             SELECT CASE ( cd_type )
6261
6262             CASE ( 'T' , 'S' , 'W' )                   ! T-, W-point
6263                DO ji = 1, jpiglo
6264                   ijt = jpiglo-ji+1
6265                   ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
6266                END DO
6267
6268             CASE ( 'U' )                               ! U-point
6269                DO ji = 1, jpiglo-1
6270                   iju = jpiglo-ji
6271                   ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
6272                END DO
6273
6274             CASE ( 'V' )                               ! V-point
6275                DO ji = 1, jpiglo
6276                   ijt = jpiglo-ji+1
6277                   ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6278                END DO
6279                DO ji = jpiglo/2+1, jpiglo
6280                   ijt = jpiglo-ji+1
6281                   ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6282                END DO
6283
6284             CASE ( 'F' , 'G' )                         ! F-point
6285                DO ji = 1, jpiglo-1
6286                   iju = jpiglo-ji
6287                   ztab(ji,ijpj  ,jk) = psgn * ztab(iju,ijpj-2,jk)
6288                END DO
6289                DO ji = jpiglo/2+1, jpiglo-1
6290                   iju = jpiglo-ji
6291                   ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6292                END DO
6293
6294             END SELECT
6295
6296          CASE DEFAULT                           ! *  closed
6297
6298             SELECT CASE ( cd_type) 
6299
6300             CASE ( 'T' , 'U' , 'V' , 'W' )      ! T-, U-, V-, W-points
6301                ztab(:, 1  ,jk) = 0.0_wp
6302                ztab(:,ijpj,jk) = 0.0_wp
6303
6304             CASE ( 'F' )                        ! F-point
6305                ztab(:,ijpj,jk) = 0.0_wp
6306
6307             END SELECT
6308
6309          END SELECT
6310
6311          !     End of slab
6312          !     ===========
6313
6314       END DO
6315#endif
6316
6317       !! Scatter back to pt3d
6318       DO jr = 1, ndim_rank_north
6319          jproc=nrank_north(jr)+1
6320          ildi=nldit (jproc)
6321          ilei=nleit (jproc)
6322          iilb=pielb(jproc)
6323!ARPDBG - make loops explicit for performance?
6324          znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = &
6325                           ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk)
6326       END DO
6327
6328    ENDIF      ! only done on proc 0 of ncomm_north
6329
6330    CALL prof_region_end(NORTH3DAPPSYMM, iprofStat)
6331
6332!ARPDBG - could do above on every 'northern' pe and then don't have to
6333! do scatter below...
6334
6335    CALL prof_region_begin(NORTH3DSCATTER, "North3DScatter", iprofStat)
6336
6337#ifdef key_mpp_shmem
6338    not done yet in shmem : compiler error
6339#elif key_mpp_mpi
6340    IF ( npolj /= 0 ) THEN
6341       itaille=nwidthmax*jpkorig*ijpj
6342       CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
6343                        znorthloc,  itaille,MPI_DOUBLE_PRECISION, &
6344                        0,ncomm_north,ierr)
6345    ENDIF
6346#endif
6347
6348    ! put in the last ijpj jlines of pt3d znorthloc while allowing
6349    ! for any trimming of domain (see earlier comments and diagram in
6350    ! mpp_lbc_north_2d).
6351#if defined key_z_first
6352    DO ij = jpjglo - jeub + 1, ijpj, 1
6353       jj = nlcj - ijpj + ij
6354       DO jk = 1 , jpk 
6355#else
6356    DO jk = 1 , jpk 
6357       DO ij = jpjglo - jeub + 1, ijpj, 1
6358          jj = nlcj - ijpj + ij
6359#endif
6360          pt3d(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij,jk)
6361       END DO
6362    END DO
6363
6364    CALL prof_region_end(NORTH3DSCATTER, iprofStat)
6365
6366#endif /* key_mpp_mpi */
6367
6368  END SUBROUTINE mpp_lbc_north_3d
6369
6370  !===================================================================
6371
6372  SUBROUTINE mpp_lbc_north_i3d ( ib3, cd_type, isgn )
6373     !!---------------------------------------------------------------------
6374     !!                   ***  routine mpp_lbc_north_3d  ***
6375     !!
6376     !! ** Purpose :
6377     !!      Ensure proper north fold horizontal bondary condition in mpp
6378     !!      configuration in case of jpn1 > 1
6379     !!
6380     !! ** Method :
6381     !!      Gather the 4 northern lines of the global domain on 1 processor
6382     !!      and apply lbc north-fold on this sub array. Then scatter the
6383     !!      fold array back to the processors.
6384     !!
6385     !! History :
6386     !!   8.5  !  03-09  (J.M. Molines ) For mpp folding condition at north
6387     !!                                  from lbc routine
6388     !!   9.0  !  03-12  (J.M. Molines ) encapsulation into lib_mpp, coding
6389     !!                                  rules of lbc_lnk
6390     !!----------------------------------------------------------------------
6391     USE par_oce, ONLY : jpni
6392     USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, &
6393                         nwidthmax
6394     USE mapcomm_mod,    ONLY : pielb, piesub
6395     USE lib_mpp, ONLY : ctl_stop
6396     IMPLICIT none
6397     !! * Arguments
6398     CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points
6399     !                                         ! = T,  U, V, F or W gridp'ts
6400     INTEGER, DIMENSION(:,:,:), INTENT( inout ) ::   &
6401          ib3          ! 3D array on which the boundary condition is applied
6402     INTEGER, INTENT( in ) ::   &
6403          isgn          ! control of the sign change
6404     !                  !   = -1. , the sign is changed if north fold boundary
6405     !                  !   =  1. , the sign is kept  if north fold boundary
6406
6407     !! * Local declarations
6408     INTEGER :: ijpj
6409     INTEGER :: ijpjm1
6410     INTEGER :: ii, ji, jj, jk, jr, jproc
6411     INTEGER :: ierr
6412     INTEGER :: ildi,ilei,iilb
6413     INTEGER :: ij,ijt,iju
6414     INTEGER :: itaille
6415
6416!FTRANS ztab :I :I :z
6417!FTRANS znorthgloio :I :I :z :
6418!FTRANS znorthloc :I :I :z
6419     INTEGER, DIMENSION(:,:,:)  , ALLOCATABLE :: ztab
6420     INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
6421     INTEGER, DIMENSION(:,:,:)  , ALLOCATABLE :: znorthloc
6422     !!----------------------------------------------------------------------
6423
6424     ! If we get in this routine it s because : North fold condition and
6425     ! mpp with more than one proc across i : we deal only with the North
6426     ! condition
6427
6428     ijpj = num_nfold_rows
6429     ijpjm1 = ijpj - 1
6430
6431     IF(.not. ALLOCATED(ztab))THEN
6432
6433        ALLOCATE(ztab(jpiglo,ijpj,jpkorig),                &
6434                 znorthgloio(nwidthmax,ijpj,jpkorig,jpni), &
6435                 znorthloc(nwidthmax,ijpj,jpkorig),        &
6436                 STAT=ierr)
6437        IF(ierr .ne. 0)THEN
6438           CALL ctl_stop('STOP','mpp_lbc_north_i3d: memory allocation failed' )
6439        END IF
6440     END IF
6441
6442     ! 0. Sign setting
6443     ! ---------------
6444
6445    ! put in znorthloc the last ijpj jlines of pt3d while allowing
6446    ! for any trimming of domain (see earlier comments and diagram in
6447    ! mpp_lbc_north_2d).
6448    znorthloc(:,:,:) = 0 ! because of padding for nwidthmax and domain
6449                         ! trimming
6450#if defined key_z_first
6451    DO ij = jpjglo - jeub + 1, ijpj, 1
6452       jj = nlcj - ijpj + ij
6453       DO jk = 1, jpk 
6454#else
6455    DO jk = 1, jpk 
6456       DO ij = jpjglo - jeub + 1, ijpj, 1
6457          jj = nlcj - ijpj + ij
6458#endif
6459          znorthloc(nldi:nlei,ij,jk) = ib3(nldi:nlei,jj,jk)
6460       END DO
6461    END DO
6462
6463
6464    IF (npolj /= 0 ) THEN
6465       ! Build in proc 0 of ncomm_north the znorthgloio
6466       znorthgloio(:,:,:,:) = 0
6467
6468#ifdef key_mpp_shmem
6469       not done : compiler error
6470#elif defined key_mpp_mpi
6471       ! All domains send this number of elements. Narrower domains
6472       ! therefore send data padded with zeros
6473       itaille=nwidthmax*jpk*ijpj
6474       CALL MPI_GATHER(znorthloc,  itaille,MPI_INTEGER, &
6475                       znorthgloio,itaille,MPI_INTEGER, &
6476                       0, ncomm_north, ierr)
6477#endif
6478
6479    ENDIF
6480
6481    IF (narea == north_root+1 ) THEN
6482       ! recover the global north array
6483       ztab(:,:,:) = 0
6484
6485       DO jr = 1, ndim_rank_north
6486          jproc = nrank_north(jr) + 1
6487          ildi  = nldit (jproc)
6488          ilei  = nleit (jproc)
6489          iilb  = pielb(jproc)
6490! ARPDBG explicit loops for performance?
6491          ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = &
6492                                  znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr)
6493       END DO
6494
6495
6496#if defined key_z_first
6497       ! 2. North-Fold boundary conditions
6498       ! ----------------------------------
6499
6500       SELECT CASE ( npolj )
6501
6502       CASE ( 3, 4 )                       ! *  North fold  T-point pivot
6503
6504          DO jk = 1, jpk, 1
6505             ztab( 1    ,ijpj,jk) = 0
6506             ztab(jpiglo,ijpj,jk) = 0
6507          END DO
6508
6509          SELECT CASE ( cd_type )
6510
6511          CASE ( 'T' , 'S' , 'W' )                   ! T-, W-point
6512             DO ji = 2, jpiglo
6513                ijt = jpiglo-ji+2
6514                DO jk = 1, jpk, 1
6515                   ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6516                END DO
6517             END DO
6518             DO ji = jpiglo/2+1, jpiglo
6519                ijt = jpiglo-ji+2
6520                DO jk = 1, jpk, 1
6521                   ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6522                END DO
6523             END DO
6524
6525          CASE ( 'U' )                               ! U-point
6526             DO ji = 1, jpiglo-1
6527                iju = jpiglo-ji+1
6528                DO jk = 1, jpk, 1
6529                   ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk)
6530                END DO
6531             END DO
6532             DO ji = jpiglo/2, jpiglo-1
6533                iju = jpiglo-ji+1
6534                DO jk = 1, jpk, 1
6535                   ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6536                END DO
6537             END DO
6538
6539          CASE ( 'V' )                               ! V-point
6540             DO ji = 2, jpiglo
6541                ijt = jpiglo-ji+2
6542                DO jk = 1, jpk, 1
6543                   ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk)
6544                   ztab(ji,ijpj  ,jk) = isgn * ztab(ijt,ijpj-3,jk)
6545                END DO
6546             END DO
6547
6548          CASE ( 'F' , 'G' )                         ! F-point
6549             DO ji = 1, jpiglo-1
6550                iju = jpiglo-ji+1
6551                DO jk = 1, jpk, 1
6552                   ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk)
6553                   ztab(ji,ijpj  ,jk) = isgn * ztab(iju,ijpj-3,jk)
6554                END DO
6555             END DO
6556
6557          END SELECT
6558
6559       CASE ( 5, 6 )                        ! *  North fold  F-point pivot
6560
6561          DO jk = 1, jpk, 1
6562             ztab( 1    ,ijpj,jk) = 0
6563             ztab(jpiglo,ijpj,jk) = 0
6564          END DO
6565
6566          SELECT CASE ( cd_type )
6567
6568          CASE ( 'T' , 'S' , 'W' )                   ! T-, W-point
6569             DO ji = 1, jpiglo
6570                ijt = jpiglo-ji+1
6571                DO jk = 1, jpk, 1
6572                   ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk)
6573                END DO
6574             END DO
6575
6576          CASE ( 'U' )                               ! U-point
6577             DO ji = 1, jpiglo-1
6578                iju = jpiglo-ji
6579                DO jk = 1, jpk, 1
6580                   ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk)
6581                END DO
6582             END DO
6583
6584          CASE ( 'V' )                               ! V-point
6585             DO ji = 1, jpiglo
6586                ijt = jpiglo-ji+1
6587                DO jk = 1, jpk, 1
6588                   ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6589                END DO
6590             END DO
6591             DO ji = jpiglo/2+1, jpiglo
6592                ijt = jpiglo-ji+1
6593                DO jk = 1, jpk, 1
6594                   ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6595                END DO
6596             END DO
6597
6598          CASE ( 'F' , 'G' )                         ! F-point
6599             DO ji = 1, jpiglo-1
6600                iju = jpiglo-ji
6601                DO jk = 1, jpk, 1
6602                   ztab(ji,ijpj  ,jk) = isgn * ztab(iju,ijpj-2,jk)
6603                END DO
6604             END DO
6605             DO ji = jpiglo/2+1, jpiglo-1
6606                iju = jpiglo-ji
6607                DO jk = 1, jpk, 1
6608                   ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6609                END DO
6610             END DO
6611
6612          END SELECT
6613
6614       CASE DEFAULT                           ! *  closed
6615
6616          SELECT CASE ( cd_type) 
6617
6618          CASE ( 'T' , 'U' , 'V' , 'W' )      ! T-, U-, V-, W-points
6619             DO ji = 1, jpiglo, 1
6620                DO jk = 1, jpk, 1
6621                   ztab(ji, 1  ,jk) = 0
6622                   ztab(ji,ijpj,jk) = 0
6623                END DO
6624             END DO
6625
6626          CASE ( 'F' )                        ! F-point
6627             DO ji = 1, jpiglo, 1
6628                DO jk = 1, jpk, 1
6629                   ztab(ji,ijpj,jk) = 0
6630                END DO
6631             END DO
6632
6633          END SELECT
6634
6635       END SELECT
6636
6637       !     End of slab
6638       !     ===========
6639#else
6640       ! Horizontal slab
6641       ! ===============
6642
6643       DO jk = 1, jpk 
6644
6645
6646          ! 2. North-Fold boundary conditions
6647          ! ----------------------------------
6648
6649          SELECT CASE ( npolj )
6650
6651          CASE ( 3, 4 )                       ! *  North fold  T-point pivot
6652
6653             ztab( 1    ,ijpj,jk) = 0
6654             ztab(jpiglo,ijpj,jk) = 0
6655
6656             SELECT CASE ( cd_type )
6657
6658             CASE ( 'T' , 'S' , 'W' )                   ! T-, W-point
6659                DO ji = 2, jpiglo
6660                   ijt = jpiglo-ji+2
6661                   ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6662                END DO
6663                DO ji = jpiglo/2+1, jpiglo
6664                   ijt = jpiglo-ji+2
6665                   ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6666                END DO
6667
6668             CASE ( 'U' )                               ! U-point
6669                DO ji = 1, jpiglo-1
6670                   iju = jpiglo-ji+1
6671                   ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk)
6672                END DO
6673                DO ji = jpiglo/2, jpiglo-1
6674                   iju = jpiglo-ji+1
6675                   ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6676                END DO
6677
6678             CASE ( 'V' )                               ! V-point
6679                DO ji = 2, jpiglo
6680                   ijt = jpiglo-ji+2
6681                   ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk)
6682                   ztab(ji,ijpj  ,jk) = isgn * ztab(ijt,ijpj-3,jk)
6683                END DO
6684
6685             CASE ( 'F' , 'G' )                         ! F-point
6686                DO ji = 1, jpiglo-1
6687                   iju = jpiglo-ji+1
6688                   ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk)
6689                   ztab(ji,ijpj  ,jk) = isgn * ztab(iju,ijpj-3,jk)
6690                END DO
6691
6692             END SELECT
6693
6694          CASE ( 5, 6 )                        ! *  North fold  F-point pivot
6695
6696             ztab( 1    ,ijpj,jk) = 0
6697             ztab(jpiglo,ijpj,jk) = 0
6698
6699             SELECT CASE ( cd_type )
6700
6701             CASE ( 'T' , 'S' , 'W' )                   ! T-, W-point
6702                DO ji = 1, jpiglo
6703                   ijt = jpiglo-ji+1
6704                   ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk)
6705                END DO
6706
6707             CASE ( 'U' )                               ! U-point
6708                DO ji = 1, jpiglo-1
6709                   iju = jpiglo-ji
6710                   ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk)
6711                END DO
6712
6713             CASE ( 'V' )                               ! V-point
6714                DO ji = 1, jpiglo
6715                   ijt = jpiglo-ji+1
6716                   ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6717                END DO
6718                DO ji = jpiglo/2+1, jpiglo
6719                   ijt = jpiglo-ji+1
6720                   ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6721                END DO
6722
6723             CASE ( 'F' , 'G' )                         ! F-point
6724                DO ji = 1, jpiglo-1
6725                   iju = jpiglo-ji
6726                   ztab(ji,ijpj  ,jk) = isgn * ztab(iju,ijpj-2,jk)
6727                END DO
6728                DO ji = jpiglo/2+1, jpiglo-1
6729                   iju = jpiglo-ji
6730                   ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6731                END DO
6732
6733             END SELECT
6734
6735          CASE DEFAULT                           ! *  closed
6736
6737             SELECT CASE ( cd_type) 
6738
6739             CASE ( 'T' , 'U' , 'V' , 'W' )      ! T-, U-, V-, W-points
6740                ztab(:, 1  ,jk) = 0
6741                ztab(:,ijpj,jk) = 0
6742
6743             CASE ( 'F' )                        ! F-point
6744                ztab(:,ijpj,jk) = 0
6745
6746             END SELECT
6747
6748          END SELECT
6749
6750          !     End of slab
6751          !     ===========
6752
6753       END DO
6754#endif
6755
6756       !! Scatter back to pt3d
6757       DO jr = 1, ndim_rank_north
6758          jproc=nrank_north(jr)+1
6759          ildi=nldit (jproc)
6760          ilei=nleit (jproc)
6761          iilb=pielb(jproc)
6762!          DO jk=  1, jpk
6763!             DO jj=1,ijpj
6764!                DO ji=ildi,ilei
6765!                   znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk)
6766!                END DO
6767!             END DO
6768!          END DO
6769          ! ARPDBG - what about halos?
6770          znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = &
6771                               ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk)
6772       END DO
6773
6774    ENDIF      ! only done on proc 0 of ncomm_north
6775
6776#ifdef key_mpp_shmem
6777    not done yet in shmem : compiler error
6778#elif key_mpp_mpi
6779    IF ( npolj /= 0 ) THEN
6780       itaille=nwidthmax*jpk*ijpj
6781       CALL MPI_SCATTER(znorthgloio,itaille,MPI_INTEGER, &
6782                        znorthloc,  itaille,MPI_INTEGER, &
6783                        0, ncomm_north, ierr)
6784    ENDIF
6785#endif
6786
6787    ! put in the last ijpj jlines of pt3d znorthloc while allowing
6788    ! for any trimming of domain (see earlier comments and diagram in
6789    ! mpp_lbc_north_2d).
6790#if defined key_z_first
6791    DO ij = jpjglo - jeub + 1, ijpj, 1
6792       jj = nlcj - ijpj + ij
6793       DO ii = nldi, nlei, 1
6794          DO jk = 1 , jpk 
6795#else
6796    DO jk = 1 , jpk 
6797       DO ij = jpjglo - jeub + 1, ijpj, 1
6798          jj = nlcj - ijpj + ij
6799          DO ii = nldi, nlei, 1
6800#endif
6801             ib3(ii,jj,jk)= znorthloc(ii,ij,jk)
6802          END DO
6803       END DO
6804    END DO
6805
6806  END SUBROUTINE mpp_lbc_north_i3d
6807
6808  !====================================================================
6809
6810END MODULE exchmod
6811
6812!     Copy n contiguous real*8 elements from a to b.
6813!     We expect the compiler to optimise this into a call
6814!     to the system memory copy routine.
6815
6816SUBROUTINE do_real8_copy( n, a, b )
6817   IMPLICIT none
6818
6819   !     arguments
6820   INTEGER, INTENT(in) :: n
6821   REAL*8, dimension(n), INTENT(in ) :: a
6822   REAL*8, DIMENSION(n), INTENT(out) :: b
6823
6824   !     local variables
6825   integer :: i
6826
6827   do i=1,n
6828      b(i) = a(i)
6829   end do
6830
6831 END SUBROUTINE do_real8_copy
Note: See TracBrowser for help on using the repository browser.