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

Context Navigation

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

Last change on this file since 4429 was 4422, checked in by trackstand2, 10 years ago
Remove manual bounds check from exchmod
File size: 230.1 KB

Line
1	MODULE 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
138	CONTAINS
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	! jpkdtamaxrecvptsnfields
2924	!!$ IF(.NOT. ALLOCATED(sendBuff))THEN
2925	!!$ ! Only allocate the sendBuff once
2926	!!$ ALLOCATE(recvBuff(jpkdtamaxrecvptsnfields,nrecv), &
2927	!!$ sendBuff(jpkdtamaxsendptsnfields,nsend),stat=ierr)
2928	!!$ WRITE(,"('Allocated ',I7,' reals for recv buff')") jpkdtamaxrecvpts*nfields
2929	!!$ WRITE(,"('Allocated ',I7,' reals for send buff')") jpkdtamaxsendpts*nfields
2930	!!$ WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)"), nfields, jpkdta
2931	!!$ ELSE
2932	!!$ ALLOCATE(recvBuff(jpkdtamaxrecvptsnfields,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	! jpkdtamaxrecvptsnfields
2941
2942	!!$ IF(.NOT. ALLOCATED(sendIBuff))THEN
2943	!!$ ALLOCATE(recvIBuff(jpkdtamaxrecvptsnfields,nrecv), &
2944	!!$ sendIBuff(jpkdtamaxsendptsnfields,nsend),stat=ierr)
2945	!!$ ELSE
2946	!!$ ALLOCATE(recvIBuff(jpkdtamaxrecvptsnfields,nrecv),stat=ierr)
2947	!!$ END IF
2948	END IF
2949
2950	IF (ierr .ne. 0) THEN
2951	WRITE(,) 'ARPDBG: failed to allocate recv buf'
2952	CALL ctl_stop('STOP','exchs_generic_list: unable to allocate recv buffs')
2953	END IF
2954
2955	! Initiate receives in case posting them first improves
2956	! performance.
2957
2958	exch_flags(handle,1:nrecv,indexr) = MPI_REQUEST_NULL
2959
2960	DO irecv=1, nrecv, 1
2961
2962	r2dcount = 0
2963	r3dcount = 0
2964	i2dcount = 0
2965	i3dcount = 0
2966
2967	IF( source(irecv).GE.0 .AND. &
2968	( (nrecvp(irecv,1) > 0) .OR. (nrecvp2d(irecv,1) > 0) ) ) THEN
2969
2970	! This loop is to allow for different fields to have different
2971	! direction requirements (possibly unecessary)
2972	DO ifield=1,nfields,1
2973
2974	IF ( enabled(dirrecv(irecv), ifield) ) THEN
2975	IF( ASSOCIATED(list(ifield)%r2dptr) )THEN
2976	r2dcount = r2dcount + nrecvp2d(irecv,1)
2977	ELSE IF( ASSOCIATED(list(ifield)%i2dptr) )THEN
2978	i2dcount = i2dcount + nrecvp2d(irecv,1)
2979	ELSE IF( ASSOCIATED(list(ifield)%r3dptr) )THEN
2980	! Allow for varying size of third dimension
2981	r3dcount = r3dcount + nrecvp(irecv,1)
2982	ELSE IF( ASSOCIATED(list(ifield)%i3dptr) )THEN
2983	! Allow for varying size of third dimension
2984	i3dcount = i3dcount + nrecvp(irecv,1)
2985	END IF
2986	END IF
2987
2988	END DO
2989
2990	tag = tag_orig + dirrecv(irecv)
2991
2992	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
2993	WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") &
2994	narea-1,tag ,source(irecv), nrecvp(irecv,1)
2995	#endif
2996
2997	IF ( r2dcount > 0 .OR. r3dcount > 0 ) THEN
2998	CALL MPI_irecv (recvBuff(1,irecv),(r2dcount+r3dcount), &
2999	MPI_DOUBLE_PRECISION, source(irecv), tag, mpi_comm_opa, &
3000	exch_flags(handle,irecv,indexr), ierr)
3001	END IF
3002	IF ( i2dcount > 0 .OR. i3dcount > 0 ) THEN
3003	CALL MPI_irecv (recvIBuff(1,irecv),(i2dcount+i3dcount), &
3004	MPI_INTEGER, source(irecv),tag, mpi_comm_opa, &
3005	exch_flags(handle,irecv,indexr),ierr)
3006	END IF
3007
3008	!!$#if defined DEBUG_COMMS
3009	!!$ WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' opp dirn = ',I1,' src = ',I3,' tag = ',I4,' flag = ',I3)") &
3010	!!$ narea-1,handle,dirrecv(irecv), &
3011	!!$ opp_dirn(dirrecv(irecv)),source(irecv), &
3012	!!$ tag, exch_flags(handle,irecv,indexr)
3013	!!$#endif
3014
3015	END IF
3016
3017	ENDDO ! Loop over receives
3018
3019
3020	! Check that all sends from previous call have completed before
3021	! we continue and modify the send buffers
3022	IF (.not. first_time) THEN
3023
3024	CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr)
3025	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3026
3027	ELSE
3028	first_time = .FALSE.
3029	END IF ! .not. first_time
3030
3031	! Now allocate/reallocate SEND buffers
3032
3033	ierr = 0
3034	newSize = maxsendpts*nfields
3035	IF( have_real_field .AND. newSize > sendBuffSize)THEN
3036	sendBuffSize=newSize
3037	IF(ALLOCATED(sendBuff))DEALLOCATE(sendBuff)
3038	ALLOCATE(sendBuff(sendBuffSize,nsend),stat=ierr)
3039
3040	!WRITE(*,"('Allocated ',I7,' reals for send buff')") sendBuffSize
3041	!WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)") nfields, jpkdta
3042	END IF
3043
3044	IF( have_int_field .AND. newSize > sendIBuffSize)THEN
3045	sendIBuffSize = newSize
3046	IF(ALLOCATED(sendIBuff))DEALLOCATE(sendIBuff)
3047	ALLOCATE(sendIBuff(sendIBuffSize,nsend),stat=ierr)
3048	END IF
3049
3050	IF (ierr .ne. 0) THEN
3051	CALL ctl_stop('STOP','exchs_generic_list: unable to allocate send buff')
3052	END IF
3053
3054	! Send all messages in the communications list.
3055
3056	exch_flags(handle,1:nsend,indexs) = MPI_REQUEST_NULL
3057
3058	DO isend=1, nsend, 1
3059
3060	rstart = 1
3061	istart = 1
3062	r2dcount = 0
3063	r3dcount = 0
3064	i2dcount = 0
3065	i3dcount = 0
3066
3067	IF ( destination(isend).GE.0 .AND. nxsend(isend).GT.0 ) THEN
3068
3069	! Loop over the fields for which we are going to exchange halos
3070	! and pack the data to send into a buffer
3071	DO ifield=1, nfields, 1
3072
3073	IF( enabled(dirsend(isend), ifield) )THEN
3074
3075	tag = tag_orig + dirsend(isend)
3076
3077	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3078	!!$ WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3079	!!$ narea-1, handle, tag, destination(isend),nsendp(isend,1)*XXX,dirsend(isend)
3080	!!$#endif
3081
3082	! Copy the data into the send buffer and send it. The
3083	! performance of this copy matters!
3084
3085	IF ( ASSOCIATED(list(ifield)%r2dptr) )THEN
3086
3087	ic = rstart - 1
3088
3089	pack_patches2r: DO ipatch=1, npatchsend(isend,1), 1
3090
3091	ibeg = isrcsendp(ipatch,isend,1)
3092	iend = ibeg + nxsendp(ipatch,isend,1)-1
3093	jbeg = jsrcsendp(ipatch,isend,1)
3094	jend = jbeg + nysendp(ipatch,isend,1)-1
3095
3096	DO j=jbeg, jend, 1
3097	DO i=ibeg, iend, 1
3098	ic = ic + 1
3099	sendBuff(ic, isend) = list(ifield)%r2dptr(i,j)
3100	END DO
3101	END DO
3102
3103	npacked = nxsendp(ipatch,isend,1) * &
3104	nysendp(ipatch,isend,1)
3105	rstart = rstart + npacked
3106	r2dcount = r2dcount + npacked
3107
3108	END DO pack_patches2r
3109
3110	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3111
3112	ic = istart - 1
3113
3114	pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1
3115
3116	jbeg = jsrcsendp(ipatch,isend,1)
3117	ibeg = isrcsendp(ipatch,isend,1)
3118	jend = jbeg + nysendp(ipatch,isend,1)-1
3119	iend = ibeg + nxsendp(ipatch,isend,1)-1
3120
3121	DO j=jbeg, jend, 1
3122	DO i=ibeg, iend, 1
3123	ic = ic + 1
3124	sendIBuff(ic,isend) = list(ifield)%i2dptr(i,j)
3125	END DO
3126	END DO
3127
3128	npacked = nxsendp(ipatch,isend,1) * &
3129	nysendp(ipatch,isend,1)
3130	istart = istart + npacked
3131	i2dcount = i2dcount + npacked
3132
3133	END DO pack_patches2i
3134
3135	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) )THEN
3136
3137	ic = rstart - 1
3138
3139	pack_patches3r: DO ipatch=1, npatchsend(isend,1), 1
3140
3141	! WRITE(*,"('Field = ',I2,' patch = ',I2,' ic = ',I4)") &
3142	! ifield, ipatch, ic
3143	jbeg = jsrcsendp(ipatch,isend,1)
3144	ibeg = isrcsendp(ipatch,isend,1)
3145	jend = jbeg + nysendp(ipatch,isend,1)-1
3146	iend = ibeg + nxsendp(ipatch,isend,1)-1
3147
3148	#if defined key_z_first
3149	DO j=jbeg, jend, 1
3150	DO i=ibeg, iend, 1
3151	!DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
3152	DO k=1, nzsendp(ipatch,isend,1), 1
3153	#else
3154	!DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
3155	DO k=1, nzsendp(ipatch,isend,1), 1
3156	DO j=jbeg, jend, 1
3157	DO i=ibeg, iend, 1
3158	#endif
3159	ic = ic + 1
3160	sendBuff(ic, isend) = list(ifield)%r3dptr(i,j,k)
3161	END DO
3162	END DO
3163	END DO
3164
3165	npacked = nxsendp(ipatch,isend,1) * &
3166	nysendp(ipatch,isend,1) * &
3167	nzsendp(ipatch,isend,1)
3168	rstart = rstart + npacked
3169	r3dcount = r3dcount + npacked
3170
3171	END DO pack_patches3r
3172
3173	ELSEIF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3174
3175	ic = istart - 1
3176
3177	pack_patches3i: DO ipatch = 1, npatchsend(isend, 1), 1
3178
3179	jbeg = jsrcsendp(ipatch,isend,1)
3180	ibeg = isrcsendp(ipatch,isend,1)
3181	jend = jbeg + nysendp(ipatch,isend,1)-1
3182	iend = ibeg + nxsendp(ipatch,isend,1)-1
3183
3184	#if defined key_z_first
3185	DO j=jbeg, jend, 1
3186	DO i=ibeg, iend, 1
3187	!DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
3188	DO k=1, nzsendp(ipatch,isend,1), 1
3189	#else
3190	!DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
3191	DO k=1, nzsendp(ipatch,isend,1), 1
3192	DO j=jbeg, jend, 1
3193	DO i=ibeg, iend, 1
3194	#endif
3195	ic = ic + 1
3196	sendIBuff(ic, isend) = list(ifield)%i3dptr(i,j,k)
3197	END DO
3198	END DO
3199	END DO
3200
3201	npacked = nxsendp(ipatch,isend,1)* &
3202	nysendp(ipatch,isend,1)* &
3203	nzsendp(ipatch,isend,1)
3204	istart = istart + npacked
3205	i3dcount = i3dcount + npacked
3206	END DO pack_patches3i
3207
3208	ENDIF
3209
3210	#if defined DEBUG_COMMS
3211	WRITE (*,FMT="(I4,': Isend to ',I3,' has flag ',I3)") &
3212	narea-1, destination(isend), exch_flags(handle,isend,indexs)
3213	#endif
3214
3215	END IF ! Direction enabled for this field
3216
3217	END DO ! Loop over fields
3218
3219	! Now do the send(s) for all fields
3220	IF(r2dcount > 0 .OR. r3dcount > 0 )THEN
3221	CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount), &
3222	MPI_DOUBLE_PRECISION, &
3223	destination(isend),tag,mpi_comm_opa, &
3224	exch_flags(handle,isend,indexs),ierr)
3225	END IF
3226	IF(i2dcount > 0 .OR. i3dcount > 0 )THEN
3227	CALL MPI_Isend(sendIBuff(1,isend),(i2dcount+i3dcount), &
3228	MPI_INTEGER, destination(isend),tag, &
3229	mpi_comm_opa, exch_flags(handle,isend,indexs),&
3230	ierr)
3231	END IF
3232
3233	ENDIF ! direction is enabled and have something to send
3234
3235	ENDDO ! Loop over sends
3236
3237	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3238	WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3239	#endif
3240
3241	! Wait on the receives that were posted earlier
3242
3243	! Copy just the set of flags we're interested in for passing to MPI_waitany
3244	exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3245
3246	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3247	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3248
3249	DO WHILE(irecv .ne. MPI_UNDEFINED)
3250
3251	istart = 1
3252	rstart = 1
3253
3254	DO ifield = 1, nfields, 1
3255
3256	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3257
3258	! Copy received data back into array
3259	ic = rstart - 1
3260	unpack_patches2r: DO ipatch=1, npatchrecv(irecv,1), 1
3261
3262	jbeg = jdesrecvp(ipatch,irecv,1)
3263	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3264	ibeg = idesrecvp(ipatch,irecv,1)
3265	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3266
3267	DO j=jbeg, jend, 1
3268	DO i=ibeg, iend, 1
3269
3270	ic = ic + 1
3271	list(ifield)%r2dptr(i,j) = recvBuff(ic,irecv)
3272	END DO
3273	END DO
3274
3275	END DO unpack_patches2r
3276
3277	! Increment starting index for next field data in buffer
3278	rstart = ic + 1 !rstart + nrecvp(irecv,1)
3279
3280	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3281
3282	! Copy received data back into array
3283	ic = istart - 1
3284	unpack_patches2i: DO ipatch = 1, npatchrecv(irecv,1), 1
3285
3286	jbeg = jdesrecvp(ipatch,irecv,1)
3287	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3288	ibeg = idesrecvp(ipatch,irecv,1)
3289	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3290
3291	DO j=jbeg, jend, 1
3292	DO i=ibeg, iend, 1
3293	ic = ic + 1
3294	list(ifield)%i2dptr(i,j) = recvIBuff(ic,irecv)
3295	END DO
3296	END DO
3297	END DO unpack_patches2i
3298
3299	! Increment starting index for next field data in buffer
3300	istart = ic + 1 !istart + nrecvp(irecv,1)
3301
3302	ELSE IF (ASSOCIATED(list(ifield)%r3dptr) ) THEN
3303
3304	ic = rstart - 1
3305	unpack_patches3r: DO ipatch=1,npatchrecv(irecv,1)
3306
3307	jbeg = jdesrecvp(ipatch,irecv,1)
3308	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3309	ibeg = idesrecvp(ipatch,irecv,1)
3310	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3311	#if defined key_z_first
3312	DO j=jbeg, jend, 1
3313	DO i=ibeg, iend, 1
3314	DO k=1, nzrecvp(ipatch,irecv,1), 1
3315	#else
3316	DO k=1, nzrecvp(ipatch,irecv,1), 1
3317	DO j=jbeg, jend, 1
3318	DO i=ibeg, iend, 1
3319	#endif
3320	ic = ic + 1
3321	list(ifield)%r3dptr(i,j,k) = recvBuff(ic,irecv)
3322	END DO
3323	END DO
3324	END DO
3325	END DO unpack_patches3r
3326
3327	! Increment starting index for next field data in buffer
3328	rstart = ic + 1 ! rstart + nrecvp(irecv,1) !*SIZE(list(ifield)%r3dptr,index_z)
3329
3330	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3331
3332	ic = istart - 1
3333	unpack_patches3i: DO ipatch=1,npatchrecv(irecv,1)
3334
3335	jbeg = jdesrecvp(ipatch,irecv,1)
3336	jend = jbeg+nyrecvp(ipatch,irecv,1)-1
3337	ibeg = idesrecvp(ipatch,irecv,1)
3338	iend = ibeg+nxrecvp(ipatch,irecv,1)-1
3339	#if defined key_z_first
3340	DO j=jbeg, jend, 1
3341	DO i=ibeg, iend, 1
3342	DO k=1,nzrecvp(ipatch,irecv,1),1
3343	#else
3344	DO k=1,nzrecvp(ipatch,irecv,1),1
3345	DO j=jbeg, jend, 1
3346	DO i=ibeg, iend, 1
3347	#endif
3348	ic = ic + 1
3349	list(ifield)%i3dptr(i,j,k) = recvIBuff(ic,irecv)
3350	END DO
3351	END DO
3352	END DO
3353	END DO unpack_patches3i
3354
3355	! Increment starting index for next field data in buffer
3356	istart = ic + 1 !istart + nrecvp(irecv,1) !*SIZE(list(ifield)%i3dptr,index_z)
3357
3358	END IF
3359
3360	END DO ! Loop over fields
3361
3362	! Wait for the next received message (if any)
3363	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3364	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3365
3366	END DO ! while irecv != MPI_UNDEFINED
3367
3368	! All receives done and unpacked - can deallocate the recv buffer now
3369	IF(ALLOCATED(recvBuff))DEALLOCATE(recvBuff)
3370	IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
3371
3372	#endif /* key_mpp_mpi */
3373
3374	! Periodic boundary condition using internal copy.
3375	! This is performed after all data has been received so that we can
3376	! also copy boundary points and avoid some diagonal communication.
3377	! Since this is just a copy we don't worry about the 'patches' of
3378	! wet points here.
3379
3380	! ARPDBG - fairly certain this code is not yet correct :-(
3381
3382	IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
3383
3384	DO ifield=1,nfields,1
3385
3386	IF ( enabled(Iplus,ifield) ) THEN
3387
3388	DO j=1,jesub+list(ifield)%halo_width
3389
3390	DO i=1,list(ifield)%halo_width
3391
3392	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3393	list(ifield)%r2dptr(iesub+i,j) = list(ifield)%r2dptr(i,j)
3394	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3395	list(ifield)%i2dptr(iesub+i,j) = list(ifield)%i2dptr(i,j)
3396	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN
3397	DO k=1,SIZE(list(ifield)%r3dptr, index_z)
3398	list(ifield)%r3dptr(iesub+i,j,k) = list(ifield)%r3dptr(i,j,k)
3399	ENDDO
3400	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3401	DO k=1,SIZE(list(ifield)%i3dptr, index_z)
3402	list(ifield)%i3dptr(iesub+i,j,k) = list(ifield)%i3dptr(i,j,k)
3403	ENDDO
3404	END IF
3405	ENDDO
3406	ENDDO
3407	END IF
3408
3409	IF ( enabled(Iminus,ifield) ) THEN
3410	!ARPDBG DO j=1,jesub,1
3411	DO j=1,jesub+list(ifield)%halo_width
3412	DO i=1, list(ifield)%halo_width
3413	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3414	!ARPDBG b2(i,j) = b2(iesub-i+1,j)
3415	list(ifield)%r2dptr(i,j) = list(ifield)%r2dptr(iesub-i+1,j)
3416	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3417	!ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
3418	list(ifield)%i2dptr(i,j) = list(ifield)%i2dptr(iesub-i+1,j)
3419	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN
3420
3421	DO k=1,SIZE(list(ifield)%r3dptr,index_z),1
3422	!ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
3423	list(ifield)%r3dptr(i,j,k) = list(ifield)%r3dptr(iesub-i+1,j,k)
3424	ENDDO
3425	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3426	DO k=1,SIZE(list(ifield)%i3dptr,index_z), 1
3427	!ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
3428	list(ifield)%i3dptr(i,j,k) = list(ifield)%i3dptr(iesub-i+1,j,k)
3429	END DO
3430	END IF
3431	END DO
3432	END DO
3433	END IF
3434
3435	END DO ! Loop over fields
3436	ENDIF ! cyclic_bc .AND. jpni==1
3437
3438	! Copy just the set of flags we're interested in for passing to
3439	! MPI_waitall next time around
3440	exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
3441
3442	! Free the exchange communications handle.
3443	CALL free_exch_handle(handle)
3444
3445	!CALL prof_region_end(ARPEXCHS_LIST, iprofStat)
3446
3447	END SUBROUTINE exchs_generic_list
3448
3449	! *********************************************************************
3450
3451	SUBROUTINE exchs_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
3452	handle, comm1, comm2, comm3, comm4, &
3453	cd_type, lfill)
3454
3455	! *******************************************************************
3456	! Send boundary data elements to adjacent sub-domains.
3457
3458	! b2(:,:) real input 2D real*8 local array.
3459	! ib2(:,:) int input 2D integer local array.
3460	! b3(:,:,:) real input 3D real*8 local array.
3461	! ib3(:,:,:) int input 3D integer local array.
3462	! nhalo int input Width of halo.
3463	! nhexch int input Number of halo
3464	! rows/cols to exchange.
3465	! handle int output Exchange handle.
3466	! comm1 int input Send in direction comm1.
3467	! comm2 int input Send in direction comm2.
3468	! comm3 int input Send in direction comm3.
3469	! comm4 int input Send in direction comm4.
3470	! cd_type char input Nature of array grid-points
3471	! = T , U , V , F , W points
3472	! = S : T-point, north fold treatment?
3473	! = G : F-point, north fold treatment?
3474	! lfill logical input Whether to simply fill
3475	! overlap region or apply b.c.'s
3476	!
3477	! Mike Ashworth, CCLRC, March 2005.
3478	! Andrew Porter, STFC, January 2008
3479	! *******************************************************************
3480	USE par_oce, ONLY: wp, jpreci, jprecj, jpni, jpkdta
3481	USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, &
3482	IminusJminus, IplusJminus, IminusJplus, &
3483	nrecv, nsend, nrecvp, nsendp, &
3484	nrecvp2d, nsendp2d, nxsend, nysend, &
3485	destination,dirsend, dirrecv, &
3486	isrcsend, jsrcsend, idesrecv, jdesrecv, &
3487	isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, &
3488	nxrecv,source, iesub, jesub, &
3489	MaxCommDir, MaxComm, idessend, jdessend, &
3490	nxsendp, nysendp, nzsendp, &
3491	nxrecvp, nyrecvp, nzrecvp, &
3492	npatchsend, npatchrecv, cyclic_bc
3493	USE lib_mpp, ONLY: ctl_stop
3494	#if defined key_mpp_mpi
3495	USE lib_mpp, ONLY: mpi_comm_opa
3496	#endif
3497	USE dom_oce, ONLY: narea
3498	USE in_out_manager, ONLY: numout
3499	IMPLICIT none
3500
3501	! Subroutine arguments.
3502	INTEGER, INTENT(in) :: nhalo,nhexch
3503	INTEGER, INTENT(out) :: handle
3504
3505	!FTRANS b3 :I :I :z
3506	!FTRANS ib3 :I :I :z
3507	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:) :: b2
3508	INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:) :: ib2
3509	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: b3
3510	INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: ib3
3511
3512	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
3513	CHARACTER(len=1), INTENT(in) :: cd_type
3514	LOGICAL, INTENT(in) :: lfill
3515
3516	! Local variables.
3517
3518	LOGICAL :: enabled(0:MaxCommDir)
3519	INTEGER :: ierr, irecv, ircvdt, isend, isnddt, &
3520	isrc, jsrc, kdim1, & ! ides, jdes, nxr, nyr, &
3521	nxs, nys, tag, tag_orig
3522	INTEGER :: maxrecvpts, maxsendpts ! Max no. of grid points involved in
3523	! any one halo exchange
3524	INTEGER :: i, j, k, ic, ipatch ! Loop counters
3525	INTEGER :: istart, iend, jstart, jend
3526	INTEGER :: index ! To hold index returned from MPI_waitany
3527	INTEGER, DIMENSION(3) :: isubsizes, istarts ! isizes
3528	#if defined key_mpp_mpi
3529	INTEGER :: status(MPI_status_size)
3530	INTEGER :: astatus(MPI_status_size,MaxComm)
3531	#endif
3532	LOGICAL, SAVE :: first_time = .TRUE.
3533	#if defined key_z_first
3534	INTEGER, PARAMETER :: index_z = 1
3535	#else
3536	INTEGER, PARAMETER :: index_z = 3
3537	#endif
3538	!!--------------------------------------------------------------------
3539
3540	#if ! defined key_mpp_rkpart
3541	RETURN
3542	#endif
3543
3544	!CALL prof_region_begin(ARPEXCHS_GENERIC, "Exchs_indiv", iprofStat)
3545	!CALL timing_start('exchs_generic')
3546
3547	ierr = 0
3548
3549	! Check nhexch is in range.
3550
3551	IF ( nhexch.GT.jpreci ) THEN
3552	CALL ctl_stop('STOP','exchs: halo width greater than maximum')
3553	ENDIF
3554
3555	! Allocate a communications tag/handle and a flags array.
3556
3557	handle = get_exch_handle()
3558	tag_orig = exch_tag(handle)
3559
3560	! Set enabled flags according to the subroutine arguments.
3561
3562	enabled(Iplus ) = .FALSE.
3563	enabled(Jplus ) = .FALSE.
3564	enabled(Iminus) = .FALSE.
3565	enabled(Jminus) = .FALSE.
3566	enabled(comm1) = comm1.GT.0
3567	enabled(comm2) = comm2.GT.0
3568	enabled(comm3) = comm3.GT.0
3569	enabled(comm4) = comm4.GT.0
3570
3571	! Set diagonal communications according to the non-diagonal flags.
3572
3573	enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
3574	enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
3575	enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
3576	enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
3577
3578	! Main communications loop.
3579	#if defined key_mpp_mpi
3580
3581	maxrecvpts = MAXVAL(nrecvp(1:nrecv,1))
3582	maxsendpts = MAXVAL(nsendp(1:nsend,1))
3583
3584	IF(PRESENT(b2) .OR. PRESENT(b3))THEN
3585	IF(.NOT. ALLOCATED(sendBuff))THEN
3586	! Only allocate the sendBuff once
3587	ALLOCATE(recvBuff(maxrecvpts,nrecv), &
3588	sendBuff(maxsendpts,nsend),stat=ierr)
3589	ELSE
3590	ALLOCATE(recvBuff(maxrecvpts,nrecv),stat=ierr)
3591	END IF
3592	ELSE IF(PRESENT(ib2) .OR. PRESENT(ib3))THEN
3593	IF(.NOT. ALLOCATED(sendIBuff))THEN
3594	ALLOCATE(recvIBuff(maxrecvpts,nrecv), &
3595	sendIBuff(maxsendpts,nsend),stat=ierr)
3596	ELSE
3597	ALLOCATE(recvIBuff(maxrecvpts,nrecv),stat=ierr)
3598	END IF
3599	END IF
3600
3601	IF (ierr .ne. 0) THEN
3602	CALL ctl_stop('STOP','exchs_generic: unable to allocate send/recvBuffs')
3603	END IF
3604
3605	! Initiate receives in case posting them first improves
3606	! performance.
3607
3608	DO irecv=1,nrecv
3609
3610	IF ( enabled(dirrecv(irecv)) .AND. &
3611	source(irecv).GE.0 .AND. nxrecv(irecv).GT.0 ) THEN
3612
3613	tag = tag_orig + dirrecv(irecv)
3614
3615	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3616	WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") narea-1,tag ,source(irecv), nrecvp(irecv,1)
3617	#endif
3618	! ARPDBG - nrecvp second rank is for multiple halo widths but
3619	! that isn't used
3620	IF ( PRESENT(b2) ) THEN
3621	CALL MPI_irecv (recvBuff(1,irecv),nrecvp2d(irecv,1), &
3622	MPI_DOUBLE_PRECISION, source(irecv), &
3623	tag, mpi_comm_opa, &
3624	exch_flags(handle,irecv,indexr), ierr)
3625	ELSEIF ( PRESENT(ib2) ) THEN
3626	CALL MPI_irecv (recvIBuff(1,irecv),nrecvp2d(irecv,1), &
3627	MPI_INTEGER, source(irecv), &
3628	tag, mpi_comm_opa, &
3629	exch_flags(handle,irecv,indexr),ierr)
3630	ELSEIF ( PRESENT(b3) ) THEN
3631	CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1), &
3632	MPI_DOUBLE_PRECISION, source(irecv), &
3633	tag, mpi_comm_opa, &
3634	exch_flags(handle,irecv,indexr),ierr)
3635	ELSEIF ( PRESENT(ib3) ) THEN
3636	CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1), &
3637	MPI_INTEGER, source(irecv), &
3638	tag, mpi_comm_opa, &
3639	exch_flags(handle,irecv,indexr),ierr)
3640	ENDIF
3641	! No point checking for MPI errors because default MPI error handler
3642	! aborts run without returning control to calling program.
3643	!IF ( ierr.NE.0 ) THEN
3644	! WRITE (numout,*) 'ARPDBG - irecv hit error'
3645	! CALL flush(numout)
3646	! CALL MPI_abort(mpi_comm_opa,1,ierr)
3647	!END IF
3648
3649	#if defined DEBUG_COMMS
3650	WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' src = ',I3,' tag = ',I4,' npoints = ',I6)") &
3651	narea-1,handle,dirrecv(irecv), &
3652	source(irecv), tag, nrecvp(irecv,1)
3653	#endif
3654
3655	ELSE
3656	exch_flags(handle,irecv,indexr) = MPI_REQUEST_NULL
3657	END IF
3658
3659	ENDDO
3660
3661	IF (.not. first_time) THEN
3662
3663	! Check that all sends from previous call have completed before
3664	! we continue to modify the send buffers
3665	CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr)
3666	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3667
3668	ELSE
3669	first_time = .FALSE.
3670	END IF ! .not. first_time
3671
3672
3673	! Send all messages in the communications list.
3674
3675	! CALL timing_start('mpi_sends')
3676
3677	DO isend=1,nsend
3678
3679	IF ( enabled(dirsend(isend)) .AND. &
3680	destination(isend) >= 0 .AND. nxsend(isend) > 0 ) THEN
3681
3682	isrc = isrcsend(isend)
3683	jsrc = jsrcsend(isend)
3684	nxs = nxsend(isend)
3685	nys = nysend(isend)
3686
3687	tag = tag_orig + dirsend(isend)
3688
3689	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3690	IF(PRESENT(b3))THEN
3691	WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3692	narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend)
3693	ELSE IF(PRESENT(b2))THEN
3694	WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3695	narea-1, handle, tag, destination(isend),nsendp2d(isend,1),dirsend(isend)
3696	END IF
3697	#endif
3698
3699	! Copy the data into the send buffer and send it...
3700
3701	IF ( PRESENT(b2) )THEN
3702
3703	! CALL timing_start('2dr_pack')
3704	ic = 0
3705	pack_patches2r: DO ipatch=1,npatchsend(isend,1)
3706	istart = isrcsendp(ipatch,isend,1)
3707	iend = istart+nxsendp(ipatch,isend,1)-1
3708	jstart = jsrcsendp(ipatch,isend,1)
3709	jend = jstart+nysendp(ipatch,isend,1)-1
3710
3711	DO j=jstart, jend, 1
3712	DO i=istart, iend, 1
3713	ic = ic + 1
3714	sendBuff(ic,isend) = b2(i,j)
3715	END DO
3716	END DO
3717
3718	!!$ ! For 'stupid' compiler that refuses to do a memcpy for above
3719	!!$ CALL do_real8_copy( nxsendp(patch,isend,1)*nysendp(patch,isend,1), &
3720	!!$ b2(istart,jstart), &
3721	!!$ sendBuff(ic,isend) )
3722	!!$ ic = ic + nxsendp(patch,isend,1)*nysendp(patch,isend,1)
3723
3724	END DO pack_patches2r
3725
3726	! CALL timing_stop('2dr_pack')
3727
3728	CALL MPI_Isend(sendBuff(1,isend),ic,MPI_DOUBLE_PRECISION, &
3729	destination(isend),tag,mpi_comm_opa, &
3730	exch_flags(handle,isend,indexs),ierr)
3731
3732	ELSEIF ( PRESENT(ib2) ) THEN
3733
3734	ic = 0
3735	pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1
3736	jstart = jsrcsendp(ipatch,isend,1)
3737	istart = isrcsendp(ipatch,isend,1)
3738	jend = jstart+nysendp(ipatch,isend,1)-1
3739	iend = istart+nxsendp(ipatch,isend,1)-1
3740
3741	DO j=jstart, jend, 1
3742	DO i=istart, iend, 1
3743	ic = ic + 1
3744	sendIBuff(ic,isend) = ib2(i,j)
3745	END DO
3746	END DO
3747	END DO pack_patches2i
3748
3749	CALL MPI_Isend(sendIBuff(1,isend),ic, MPI_INTEGER, &
3750	destination(isend),tag,mpi_comm_opa,&
3751	exch_flags(handle,isend,indexs),ierr)
3752
3753	ELSEIF ( PRESENT(b3) )THEN
3754
3755	! CALL timing_start('3dr_pack')
3756	ic = 0
3757	pack_patches3r: DO ipatch=1,npatchsend(isend,1)
3758
3759	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	DO k=1,nzsendp(ipatch,isend,1),1
3767	#else
3768	DO k=1,nzsendp(ipatch,isend,1),1
3769	DO j=jstart, jend, 1
3770	DO i=istart, iend, 1
3771	#endif
3772	ic = ic + 1
3773	sendBuff(ic, isend) = b3(i,j,k)
3774	END DO
3775	END DO
3776	END DO
3777	END DO pack_patches3r
3778
3779	! CALL timing_stop('3dr_pack')
3780
3781	CALL MPI_Isend(sendBuff(1,isend),ic, &
3782	MPI_DOUBLE_PRECISION, &
3783	destination(isend), tag, mpi_comm_opa, &
3784	exch_flags(handle,isend,indexs),ierr)
3785
3786	#if defined DEBUG_COMMS
3787	WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &
3788	narea-1, npatchsend(isend,1),ic, &
3789	destination(isend)
3790	#endif
3791
3792	ELSEIF ( PRESENT(ib3) ) THEN
3793
3794	ic = 0
3795	pack_patches3i: DO ipatch=1,npatchsend(isend,1)
3796	jstart = jsrcsendp(ipatch,isend,1) !+nhalo
3797	istart = isrcsendp(ipatch,isend,1) !+nhalo
3798	jend = jstart+nysendp(ipatch,isend,1)-1
3799	iend = istart+nxsendp(ipatch,isend,1)-1
3800	#if defined key_z_first
3801	DO j=jstart, jend, 1
3802	DO i=istart, iend, 1
3803	DO k=1,nzsendp(ipatch,isend,1),1
3804	#else
3805	DO k=1,nzsendp(ipatch,isend,1),1
3806	DO j=jstart, jend, 1
3807	DO i=istart, iend, 1
3808	#endif
3809	ic = ic + 1
3810	sendIBuff(ic, isend) = ib3(i,j,k)
3811	END DO
3812	END DO
3813	END DO
3814	END DO pack_patches3i
3815
3816	CALL MPI_Isend(sendIBuff(1,isend),ic, &
3817	MPI_INTEGER, &
3818	destination(isend),tag,mpi_comm_opa, &
3819	exch_flags(handle,isend,indexs),ierr)
3820	ENDIF
3821
3822	!IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3823
3824	ELSE
3825
3826	exch_flags(handle,isend,indexs) = MPI_REQUEST_NULL
3827
3828	ENDIF ! direction is enabled and have something to send
3829
3830	ENDDO ! Loop over sends
3831
3832	! CALL timing_stop('mpi_sends')
3833
3834	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3835	WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3836	#endif
3837
3838	! Wait on the receives that were posted earlier
3839
3840	! CALL timing_start('mpi_recvs')
3841
3842	! Copy just the set of flags we're interested in for passing
3843	! to MPI_waitany
3844	exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3845
3846	#if defined DEBUG_COMMS
3847	WRITE(*,"(I3,': Doing waitany: nrecv =',I3,' handle = ',I3)") &
3848	narea-1, nrecv,handle
3849	#endif
3850
3851	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3852	IF ( ierr .NE. MPI_SUCCESS ) THEN
3853
3854	IF(ierr .EQ. MPI_ERR_REQUEST)THEN
3855	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_REQUEST')") narea-1
3856	ELSE IF(ierr .EQ. MPI_ERR_ARG)THEN
3857	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_ARG')") narea-1
3858	ELSE
3859	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1
3860	END IF
3861	CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error')
3862	END IF
3863
3864	DO WHILE(irecv .ne. MPI_UNDEFINED)
3865
3866	IF ( PRESENT(b2) ) THEN
3867
3868	! CALL timing_start('2dr_unpack')
3869
3870	! Copy received data back into array
3871	ic = 0
3872	unpack_patches2r: DO ipatch=1,npatchrecv(irecv,nhexch)
3873
3874	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3875	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3876	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3877	iend = istart+nxrecvp(ipatch,irecv,1)-1
3878	DO j=jstart, jend, 1
3879	DO i=istart, iend, 1
3880	ic = ic + 1
3881	b2(i,j) = recvBuff(ic,irecv)
3882	END DO
3883	END DO
3884	END DO unpack_patches2r
3885
3886	! CALL timing_stop('2dr_unpack')
3887
3888	ELSE IF ( PRESENT(ib2) ) THEN
3889
3890	! Copy received data back into array
3891	ic = 0
3892	unpack_patches2i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3893
3894	jstart = jdesrecvp(ipatch,irecv,1)
3895	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3896	istart = idesrecvp(ipatch,irecv,1)
3897	iend = istart+nxrecvp(ipatch,irecv,1)-1
3898	DO j=jstart, jend, 1
3899	DO i=istart, iend, 1
3900	ic = ic + 1
3901	ib2(i,j) = recvIBuff(ic,irecv)
3902	END DO
3903	END DO
3904	END DO unpack_patches2i
3905
3906	ELSE IF (PRESENT(b3) ) THEN
3907
3908	! CALL timing_start('3dr_unpack')
3909	ic = 0
3910	unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch)
3911
3912	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3913	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3914	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3915	iend = istart+nxrecvp(ipatch,irecv,1)-1
3916
3917	#if defined key_z_first
3918	DO j=jstart, jend, 1
3919	DO i=istart, iend, 1
3920	DO k=1,nzrecvp(ipatch,irecv,1),1
3921	#else
3922	DO k=1,nzrecvp(ipatch,irecv,1),1
3923	DO j=jstart, jend, 1
3924	DO i=istart, iend, 1
3925	#endif
3926	ic = ic + 1
3927	b3(i,j,k) = recvBuff(ic,irecv)
3928	END DO
3929	#if defined key_z_first
3930	! ARPDBG - wipe anything below the ocean bottom
3931	DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3932	b3(i,j,k) = 0.0_wp
3933	END DO
3934	#endif
3935	END DO
3936	END DO
3937
3938	! ARPDBG - wipe anything below the ocean bottom
3939	#if ! defined key_z_first
3940	DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3941	DO j=jstart, jend, 1
3942	DO i=istart, iend, 1
3943	b3(i,j,k) = 0.0_wp
3944	END DO
3945	END DO
3946	END DO
3947	#endif
3948
3949	END DO unpack_patches3r
3950
3951	! CALL timing_stop('3dr_unpack')
3952
3953	ELSEIF ( PRESENT(ib3) ) THEN
3954
3955	ic = 0
3956	unpack_patches3i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3957
3958	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3959	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3960	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3961	iend = istart+nxrecvp(ipatch,irecv,1)-1
3962	#if defined key_z_first
3963	DO j=jstart, jend, 1
3964	DO i=istart, iend, 1
3965	DO k=1,nzrecvp(ipatch,irecv,1),1
3966	#else
3967	DO k=1,nzrecvp(ipatch,irecv,1),1
3968	DO j=jstart, jend, 1
3969	DO i=istart, iend, 1
3970	#endif
3971	ic = ic + 1
3972	ib3(i,j,k) = recvIBuff(ic,irecv)
3973	END DO
3974	END DO
3975	END DO
3976	END DO unpack_patches3i
3977
3978	END IF
3979
3980	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3981	!IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3982
3983	END DO ! while irecv != MPI_UNDEFINED
3984
3985	! CALL timing_stop('mpi_recvs')
3986
3987	! All receives done and unpacked so can deallocate the associated
3988	! buffers
3989	!IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)
3990	!IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
3991
3992	#if defined DEBUG_COMMS
3993	WRITE(*,"(I3,': Finished all ',I3,' receives for handle ',I3)") &
3994	narea-1, nrecv, handle
3995	#endif
3996
3997	#endif /* key_mpp_mpi */
3998
3999	! Periodic boundary condition using internal copy.
4000	! This is performed after all data has been received so that we can
4001	! also copy boundary points and avoid some diagonal communication.
4002	!
4003	! ARPDBG - performance issue: need to hoist IF block outside nested
4004	! loop!
4005	IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
4006
4007	! Find out the sizes of the arrays.
4008	kdim1 = 1
4009	IF ( PRESENT(b3) ) THEN
4010	kdim1 = SIZE(b3,dim=index_z)
4011	ELSEIF ( PRESENT(ib3) ) THEN
4012	kdim1 = SIZE(ib3,dim=index_z)
4013	ENDIF
4014
4015
4016	IF ( enabled(Iplus) ) THEN
4017	!ARPDBG DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4018	DO j=1,jesub+jpreci
4019	!ARPDBG DO i=nhexch,1,-1
4020	DO i=1,jpreci
4021	IF ( PRESENT(b2) ) THEN
4022	!ARPDBG b2(iesub-i+1,j) = b2(i,j)
4023	b2(iesub+i,j) = b2(i,j)
4024	ELSEIF ( PRESENT(ib2) ) THEN
4025	!ARPDBG ib2(iesub-i+1,j) = ib2(i,j)
4026	ib2(iesub+i,j) = ib2(i,j)
4027	ELSEIF ( PRESENT(b3) ) THEN
4028	! dir$ unroll
4029	DO k=1,kdim1
4030	!ARPDBG b3(k,iesub-i+1,j) = b3(k,i,j)
4031	b3(k,iesub+i,j) = b3(k,i,j)
4032	ENDDO
4033	ELSEIF ( PRESENT(ib3) ) THEN
4034	! dir$ unroll
4035	DO k=1,kdim1
4036	!ARPDBG ib3(k,iesub-i+1,j) = ib3(k,i,j)
4037	ib3(k,iesub+i,j) = ib3(k,i,j)
4038	ENDDO
4039	ENDIF
4040	ENDDO
4041	ENDDO
4042	ENDIF
4043
4044	IF ( enabled(Iminus) ) THEN
4045	!ARPDBG DO j=1,jesub,1
4046	DO j=1,jesub+jpreci
4047	DO i=1,jpreci
4048	IF ( PRESENT(b2) ) THEN
4049	!ARPDBG b2(i,j) = b2(iesub-i+1,j)
4050	b2(1-i,j) = b2(iesub-i+1,j)
4051	ELSEIF ( PRESENT(ib2) ) THEN
4052	!ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
4053	ib2(1-i,j) = ib2(iesub-i+1,j)
4054	ELSEIF ( PRESENT(b3) ) THEN
4055	! dir$ unroll
4056	DO k=1,kdim1
4057	!ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
4058	b3(1-i,j,k) = b3(iesub-i+1,j,k)
4059	ENDDO
4060	ELSEIF ( PRESENT(ib3) ) THEN
4061	! dir$ unroll
4062	DO k=1,kdim1
4063	!ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
4064	ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4065	ENDDO
4066	ENDIF
4067	ENDDO
4068	ENDDO
4069	ENDIF
4070
4071	ENDIF ! cyclic_bc .AND. jpni == 1
4072
4073	! Copy just the set of flags we're interested in for passing to
4074	! MPI_waitall next time around
4075	exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
4076
4077	! Free the exchange communications handle.
4078	CALL free_exch_handle(handle)
4079
4080	! All receives done so we can safely free the MPI receive buffers
4081	IF( ALLOCATED(recvBuff) ) DEALLOCATE(recvBuff)
4082	IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff)
4083
4084	! CALL timing_stop('exchs_generic')
4085	!CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat)
4086
4087	END SUBROUTINE exchs_generic
4088
4089	! ********************************************************************
4090
4091	!!$ SUBROUTINE exchr_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
4092	!!$ handle, comm1, comm2, comm3, comm4 )
4093	!!$
4094	!!$ ! ******************************************************************
4095	!!$
4096	!!$ ! Receive boundary data elements from adjacent sub-domains.
4097	!!$
4098	!!$ ! b2(1-nhalo:,1-nhalo:) real input 2D real*8 local array.
4099	!!$ ! ib2(1-nhalo:,1-nhalo:) int input 2D integer local array.
4100	!!$ ! b3(:,1-nhalo:,1-nhalo:) real input 3D real*8 local array.
4101	!!$ ! ib3(:,1-nhalo:,1-nhalo:) int input 3D integer local array.
4102	!!$ ! nhalo int input Width of halo.
4103	!!$ ! nhexch int input Number of halo
4104	!!$ ! rows/cols to exchange.
4105	!!$ ! handle int input Exchange handle.
4106	!!$ ! comm1 int input Send in direction comm1.
4107	!!$ ! comm2 int input Send in direction comm2.
4108	!!$ ! comm3 int input Send in direction comm3.
4109	!!$ ! comm4 int input Send in direction comm4.
4110	!!$
4111	!!$ ! Mike Ashworth, CCLRC, March 2005.
4112	!!$
4113	!!$ ! ******************************************************************
4114	!!$ USE mapcomm_mod, ONLY: iesub,jesub,MaxCommDir,Iplus,Jplus,Iminus, &
4115	!!$ Jminus, IplusJplus,IminusJminus,IplusJminus, &
4116	!!$ IminusJplus, nrecv, nxrecv,nyrecv, source, dirrecv, &
4117	!!$ idesrecv, jdesrecv, cyclic_bc, destination, &
4118	!!$ nsend, nxsend, dirsend
4119	!!$ !ARPDBG: do_exchanges below is debug only
4120	!!$ USE par_oce, ONLY: jpni, jpreci, wp, do_exchanges
4121	!!$ USE lib_mpp, ONLY: mpi_comm_opa
4122	!!$ USE dom_oce, ONLY: narea
4123	!!$#ifdef WITH_LIBHMD
4124	!!$ USE in_out_manager, ONLY: lwp
4125	!!$#endif
4126	!!$ IMPLICIT NONE
4127	!!$
4128	!!$ INTEGER :: status(MPI_status_size)
4129	!!$
4130	!!$ ! Subroutine arguments.
4131	!!$!xxFTRANS b3 :I :I :z
4132	!!$!xxFTRANS ib3 :I :I :z
4133	!!$ INTEGER, INTENT(In) :: nhalo,nhexch,handle
4134	!!$ REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:) :: b2
4135	!!$ INTEGER, INTENT(inout), OPTIONAL, DIMENSION(:,:) :: ib2
4136	!!$ REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: b3
4137	!!$ INTEGER, INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: ib3
4138	!!$ INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
4139	!!$
4140	!!$ ! Local variables.
4141	!!$
4142	!!$ LOGICAL :: enabled(0:MaxCommDir)
4143	!!$ INTEGER :: i, ides, ierr, irecv, isend, j, jdes, k, &
4144	!!$ kdim1, nxr, nyr
4145	!!$
4146	!!$#ifdef PARALLEL_STATS
4147	!!$ LOGICAL :: probe
4148	!!$ INTEGER :: nbpw
4149	!!$#endif
4150	!!$
4151	!!$ IF(.not. do_exchanges)THEN
4152	!!$ WRITE (,) 'ARPDBG: exchr_generic: do_exchanges is FALSE'
4153	!!$ RETURN ! ARPDBG
4154	!!$ END IF
4155	!!$
4156	!!$#ifdef PARALLEL_STATS
4157	!!$ IF ( PRESENT(b2) .OR. PRESENT(b3) ) THEN
4158	!!$ nbpw = 8
4159	!!$ ELSE
4160	!!$ nbpw = nbpi
4161	!!$ ENDIF
4162	!!$#endif
4163	!!$
4164	!!$ ! Find out the sizes of the arrays.
4165	!!$
4166	!!$ kdim1 = 1
4167	!!$ IF ( PRESENT(b3) ) THEN
4168	!!$!! DCSE_NEMO - bug here in original code?
4169	!!$! Code used to say kdim1 = SIZE(b3,dim=1) whereas ARP thinks it should
4170	!!$! have had dim=3. Ditto for ib3 below.
4171	!!$#if defined key_z_first
4172	!!$ kdim1 = SIZE(b3,dim=1)
4173	!!$#else
4174	!!$ kdim1 = SIZE(b3,dim=3)
4175	!!$#endif
4176	!!$! isizes(3) = kdim1
4177	!!$! isizes(2) = SIZE(b3,dim=2)
4178	!!$! isizes(1) = SIZE(b3,dim=1)
4179	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4180	!!$#if defined key_z_first
4181	!!$ kdim1 = SIZE(ib3,dim=1)
4182	!!$#else
4183	!!$ kdim1 = SIZE(ib3,dim=3)
4184	!!$#endif
4185	!!$! isizes(3) = kdim1
4186	!!$! isizes(2) = SIZE(ib3,dim=2)
4187	!!$! isizes(1) = SIZE(ib3,dim=1)
4188	!!$ ENDIF
4189	!!$
4190	!!$ ! Check nhexch is in range.
4191	!!$
4192	!!$ IF ( nhexch.GT.jpreci ) THEN
4193	!!$ STOP 'exchr: halo width greater than maximum'
4194	!!$ ENDIF
4195	!!$
4196	!!$ ! Set enabled flags according to the subroutine arguments.
4197	!!$
4198	!!$ enabled(Iplus ) = .FALSE.
4199	!!$ enabled(Jplus ) = .FALSE.
4200	!!$ enabled(Iminus) = .FALSE.
4201	!!$ enabled(Jminus) = .FALSE.
4202	!!$ enabled(comm1) = comm1.GT.0
4203	!!$ enabled(comm2) = comm2.GT.0
4204	!!$ enabled(comm3) = comm3.GT.0
4205	!!$ enabled(comm4) = comm4.GT.0
4206	!!$
4207	!!$ ! Set diagonal communications according to the non-diagonal flags.
4208	!!$
4209	!!$ enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
4210	!!$ enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
4211	!!$ enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
4212	!!$ enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
4213	!!$
4214	!!$ ! Main communications loop.
4215	!!$
4216	!!$ ! Receive all messages in the communications list.
4217	!!$
4218	!!$ DO irecv=1,nrecv
4219	!!$
4220	!!$ IF ( enabled(dirrecv(irecv)) .AND. source(irecv).GE.0 &
4221	!!$! .AND. nxrecv(irecv,nhexch).GT.0 ) THEN
4222	!!$ .AND. nxrecv(irecv).GT.0 ) THEN
4223	!!$
4224	!!$! ides = idesrecv(irecv,nhexch)
4225	!!$! jdes = jdesrecv(irecv,nhexch)
4226	!!$! nxr = nxrecv(irecv,nhexch)
4227	!!$! nyr = nyrecv(irecv,nhexch)
4228	!!$ ides = idesrecv(irecv)
4229	!!$ jdes = jdesrecv(irecv)
4230	!!$ nxr = nxrecv(irecv)
4231	!!$ nyr = nyrecv(irecv)
4232	!!$
4233	!!$ ! Wait on the receives that were actually posted in the send routine
4234	!!$
4235	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
4236	!!$ WRITE (*,FMT="(I4,': test for recv from ',I3,' data ',I3,' x ',I3,' to ',I3,I3)") narea-1,source(irecv),nxr,nyr,ides,jdes
4237	!!$ WRITE (*,FMT="(I4,': test flag = ',I3)") narea-1, &
4238	!!$ exch_flags(handle,irecv,indexr)
4239	!!$#endif
4240	!!$
4241	!!$#ifdef PARALLEL_STATS
4242	!!$ CALL MPI_test (exch_flags(handle,irecv,indexr),probe,status,ierr)
4243	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4244	!!$ IF ( .NOT.probe ) THEN
4245	!!$ nmwait = nmwait+1
4246	!!$ ENDIF
4247	!!$#endif /* PARALLEL_STATS */
4248	!!$ CALL MPI_wait (exch_flags(handle,irecv,indexr),status,ierr)
4249	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4250	!!$
4251	!!$#ifdef PARALLEL_STATS
4252	!!$ nmrecv = nmrecv + 1
4253	!!$ nbrecv = nbrecv + kdim1nbpwnxr*nyr
4254	!!$
4255	!!$#endif /* PARALLEL_STATS */
4256	!!$ ENDIF
4257	!!$
4258	!!$ ENDDO
4259	!!$
4260	!!$ ! Periodic boundary condition using internal copy.
4261	!!$ ! This is performed after all data has been received so that we can
4262	!!$ ! also copy boundary points and avoid some diagonal communication.
4263	!!$
4264	!!$ IF ( cyclic_bc .AND. jpni.EQ.1 ) THEN
4265	!!$
4266	!!$ IF ( enabled(Iplus) ) THEN
4267	!!$ !ARPDBG DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4268	!!$!ARPDBG - broken? Loop over j is used as 3rd index in 3D arrays
4269	!!$!ARPDBG but kdim1 is correctly(?) set to extent of first dimension
4270	!!$ DO j=1,jesub+jpreci
4271	!!$ !ARPDBG DO i=nhexch,1,-1
4272	!!$ DO i=1,jpreci
4273	!!$ IF ( PRESENT(b2) ) THEN
4274	!!$ !ARPDBG b2(iesub-i+1,j) = b2(i,j)
4275	!!$ b2(iesub+i,j) = b2(i,j)
4276	!!$ ELSEIF ( PRESENT(ib2) ) THEN
4277	!!$ !ARPDBG ib2(iesub-i+1,j) = ib2(i,j)
4278	!!$ ib2(iesub+i,j) = ib2(i,j)
4279	!!$ ELSEIF ( PRESENT(b3) ) THEN
4280	!!$ ! dir$ unroll
4281	!!$ DO k=1,kdim1
4282	!!$ !ARPDBG b3(k,iesub-i+1,j) = b3(k,i,j)
4283	!!$ b3(k,iesub+i,j) = b3(k,i,j)
4284	!!$ ENDDO
4285	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4286	!!$ ! dir$ unroll
4287	!!$ DO k=1,kdim1
4288	!!$ !ARPDBG ib3(k,iesub-i+1,j) = ib3(k,i,j)
4289	!!$ ib3(k,iesub+i,j) = ib3(k,i,j)
4290	!!$ ENDDO
4291	!!$ ENDIF
4292	!!$ ENDDO
4293	!!$ ENDDO
4294	!!$ ENDIF
4295	!!$
4296	!!$ IF ( enabled(Iminus) ) THEN
4297	!!$ !ARPDBG DO j=1,jesub,1
4298	!!$ DO j=1,jesub+jpreci
4299	!!$ DO i=1,jpreci
4300	!!$ IF ( PRESENT(b2) ) THEN
4301	!!$ !ARPDBG b2(i,j) = b2(iesub-i+1,j)
4302	!!$ b2(1-i,j) = b2(iesub-i+1,j)
4303	!!$ ELSEIF ( PRESENT(ib2) ) THEN
4304	!!$ !ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
4305	!!$ ib2(1-i,j) = ib2(iesub-i+1,j)
4306	!!$ ELSEIF ( PRESENT(b3) ) THEN
4307	!!$ ! dir$ unroll
4308	!!$ DO k=1,kdim1
4309	!!$ !ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
4310	!!$ b3(1-i,j,k) = b3(iesub-i+1,j,k)
4311	!!$ ENDDO
4312	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4313	!!$ ! dir$ unroll
4314	!!$ DO k=1,kdim1
4315	!!$ !ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
4316	!!$ ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4317	!!$ ENDDO
4318	!!$ ENDIF
4319	!!$ ENDDO
4320	!!$ ENDDO
4321	!!$ ENDIF
4322	!!$
4323	!!$ ENDIF
4324	!!$
4325	!!$ IF ( immed ) THEN
4326	!!$
4327	!!$ ! Check completion for immediate sends.
4328	!!$
4329	!!$ DO isend=1,nsend
4330	!!$
4331	!!$ IF (enabled(dirsend(isend)) .AND. &
4332	!!$ destination(isend).GE.0 .AND. nxsend(isend,nhexch).GT.0 ) THEN
4333	!!$
4334	!!$ CALL MPI_wait (exch_flags(handle,isend,indexs),status,ierr)
4335	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4336	!!$
4337	!!$ ENDIF
4338	!!$
4339	!!$ ENDDO
4340	!!$
4341	!!$ ENDIF
4342	!!$
4343	!!$ ! Free the exchange communications handle.
4344	!!$
4345	!!$ CALL free_exch_handle(handle)
4346	!!$
4347	!!$ END SUBROUTINE exchr_generic
4348
4349	!=======================================================================
4350
4351	SUBROUTINE mpp_lbc_north_list(list, nfields)
4352	USE par_oce, ONLY : jpni, jpi, jpj
4353	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
4354	nwidthmax
4355	USE mapcomm_mod, ONLY : pielb, piesub
4356	USE lib_mpp, ONLY : ctl_stop
4357	IMPLICIT none
4358	! Subroutine arguments.
4359	TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
4360	INTEGER, INTENT(in) :: nfields
4361
4362	!! * Local declarations
4363	INTEGER :: ijpj ! No. of rows to operate upon
4364	INTEGER :: ii, ji, jj, jk, jji, jjr, jr, jproc, klimit
4365	INTEGER :: ierr, ifield, ishifti, ishiftr
4366	INTEGER :: ildi,ilei,iilb
4367	INTEGER :: ij,ijt,iju, isgn
4368	INTEGER :: itaille
4369	!FTRANS ztab :I :I :z
4370	!FTRANS iztab :I :I :z
4371	!FTRANS znorthgloio :I :I :z :
4372	!FTRANS iznorthgloio :I :I :z :
4373	!FTRANS znorthloc :I :I :z
4374	!FTRANS iznorthloc :I :I :z
4375	INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: iztab
4376	INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: iznorthgloio
4377	INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: iznorthloc
4378	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ztab
4379	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio
4380	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthloc
4381	REAL(wp) :: psgn ! control of the sign change
4382	LOGICAL :: field_is_real, fields_all_real, fields_all_int
4383	LOGICAL :: fields_all_3d, fields_all_2d
4384	!!----------------------------------------------------------------------
4385
4386	CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat)
4387
4388	#if defined key_mpp_mpi
4389
4390	! If we get into this routine it's because : North fold condition and mpp
4391	! with more than one PE across i : we deal only with the North condition
4392
4393	! Set no. of rows from a module parameter that is also used in exchtestmod
4394	! and mpp_ini_north
4395	ijpj = num_nfold_rows
4396
4397	! Allocate work-space arrays
4398	IF(.not. ALLOCATED(ztab))THEN
4399
4400	ALLOCATE(ztab(jpiglo,maxExchItems*ijpj,jpkorig), &
4401	iztab(jpiglo,maxExchItems*ijpj,jpkorig), &
4402	znorthgloio(nwidthmax,maxExchItems*ijpj,jpkorig,jpni), &
4403	znorthloc(nwidthmax,maxExchItems*ijpj,jpkorig), &
4404	iznorthgloio(nwidthmax,maxExchItems*ijpj,jpkorig,jpni), &
4405	iznorthloc(nwidthmax,maxExchItems*ijpj,jpkorig), &
4406	STAT=ierr)
4407	IF(ierr .ne. 0)THEN
4408	CALL ctl_stop('STOP','mpp_lbc_north_list: memory allocation failed')
4409	RETURN
4410	END IF
4411	END IF
4412
4413	! put the last ijpj jlines of each real field into znorthloc
4414	! znorthloc(:,:,:) = 0_wp ! because of padding for nwidthmax
4415	! iznorthloc(:,:,:) = 0
4416	ishiftr = 0
4417	ishifti = 0
4418	fields_all_real = .TRUE.
4419	fields_all_int = .TRUE.
4420	fields_all_3d = .TRUE.
4421	fields_all_2d = .TRUE.
4422
4423	CALL prof_region_begin(NORTHLISTGATHER, "NorthListGather", iprofStat)
4424
4425	DO ifield=1,nfields,1
4426
4427	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
4428	DO ij = 1, ijpj, 1
4429	jj = nlcj - ijpj + ij
4430	znorthloc(nldi:nlei,ij+ishiftr,1) = &
4431	list(ifield)%r2dptr(nldi:nlei,jj)
4432	END DO
4433
4434	ishiftr = ishiftr + ijpj
4435	fields_all_int = .FALSE.
4436	fields_all_3d = .FALSE.
4437	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
4438
4439	#if defined key_z_first
4440	DO ij = 1, ijpj, 1
4441	jj = nlcj - ijpj + ij
4442	DO ii = nldi, nlei, 1
4443	DO jk = 1, jpk
4444	#else
4445	DO jk = 1, jpk
4446	DO ij = 1, ijpj, 1
4447	jj = nlcj - ijpj + ij
4448	DO ii = nldi, nlei, 1
4449	#endif
4450	znorthloc(ii,ij+ishiftr,jk) = &
4451	list(ifield)%r3dptr(ii,jj,jk)
4452	END DO
4453	END DO
4454	END DO
4455
4456	ishiftr = ishiftr + ijpj
4457	fields_all_int = .FALSE.
4458	fields_all_2d = .FALSE.
4459	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
4460
4461	DO ij = 1, ijpj, 1
4462	jj = nlcj - ijpj + ij
4463	iznorthloc(nldi:nlei,ij+ishifti,1) = &
4464	list(ifield)%i2dptr(nldi:nlei,jj)
4465	END DO
4466
4467	ishifti = ishifti + ijpj
4468	fields_all_real = .FALSE.
4469	fields_all_3d = .FALSE.
4470	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
4471
4472	#if defined key_z_first
4473	DO ij = 1, ijpj, 1
4474	jj = nlcj - ijpj + ij
4475	DO ii = nldi, nlei, 1
4476	DO jk = 1, jpk
4477	#else
4478	DO jk = 1, jpk
4479	DO ij = 1, ijpj, 1
4480	jj = nlcj - ijpj + ij
4481	DO ii = nldi, nlei, 1
4482	#endif
4483	iznorthloc(ii,ij+ishifti,jk) = &
4484	list(ifield)%i3dptr(ii,jj,jk)
4485	END DO
4486	END DO
4487	END DO
4488
4489	ishifti = ishifti + ijpj
4490	fields_all_real = .FALSE.
4491	fields_all_2d = .FALSE.
4492	END IF
4493
4494	END DO ! loop over fields
4495
4496	klimit = 1
4497	IF(.not. fields_all_2d)klimit = jpk
4498
4499	IF (npolj /= 0 ) THEN
4500	IF(.NOT. fields_all_int )THEN
4501	! Build znorthgloio on proc 0 of ncomm_north
4502	!znorthgloio(:,:,:,:) = 0_wp
4503	itaille=nwidthmaxishiftrklimit
4504	#if defined key_mpp_mpi
4505	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, &
4506	znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
4507	0, ncomm_north, ierr)
4508	#endif
4509	END IF
4510	IF(.NOT. fields_all_real )THEN
4511	! Build iznorthgloio on proc 0 of ncomm_north
4512	!iznorthgloio(:,:,:,:) = 0
4513	itaille=nwidthmaxishiftiklimit
4514	#if defined key_mpp_mpi
4515	CALL MPI_GATHER(iznorthloc,itaille,MPI_INTEGER, &
4516	iznorthgloio,itaille,MPI_INTEGER,&
4517	0, ncomm_north, ierr)
4518	#endif
4519	END IF
4520	ENDIF
4521
4522	CALL prof_region_end(NORTHLISTGATHER, iprofStat)
4523
4524	CALL prof_region_begin(ARPNORTHAPPLYSYMM, "NorthListApplySymm", iprofStat)
4525
4526	IF (narea == north_root+1 ) THEN
4527	! recover the global north array for every field
4528	! ztab(:,:,:) = 0_wp
4529	! iztab(:,:,:) = 0_wp
4530
4531	IF( .NOT. fields_all_int )THEN
4532
4533	DO jr = 1, ndim_rank_north
4534	jproc = nrank_north(jr) + 1
4535	ildi = nldit (jproc)
4536	ilei = nleit (jproc)
4537	iilb = pielb(jproc)
4538	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:jpk) = &
4539	znorthgloio(ildi:ilei,1:ishiftr,1:jpk,jr)
4540	END DO
4541	END IF
4542	IF( .NOT. fields_all_real )THEN
4543
4544	DO jr = 1, ndim_rank_north
4545	jproc = nrank_north(jr) + 1
4546	ildi = nldit (jproc)
4547	ilei = nleit (jproc)
4548	iilb = pielb(jproc)
4549	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:jpk) = &
4550	iznorthgloio(ildi:ilei,1:ishifti,1:jpk,jr)
4551	END DO
4552	END IF
4553
4554	! Horizontal slab
4555	! ===============
4556
4557	jji = ijpj
4558	jjr = ijpj
4559
4560	! 2. North-Fold boundary conditions
4561	! ----------------------------------
4562
4563	SELECT CASE ( npolj )
4564
4565	CASE ( 3, 4 ) ! * North fold T-point pivot
4566
4567	DO ifield=1, nfields, 1
4568
4569	! Set-up stuff dependent on whether this field is real or integer
4570	field_is_real = .FALSE.
4571	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4572	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
4573
4574	isgn = list(ifield)%isgn
4575	psgn = REAL(isgn, wp)
4576
4577	! Set up stuff dependent on whether this field is 2- or 3-dimensional
4578	IF(fields_all_3d)THEN
4579	klimit=jpk
4580	ELSE IF(fields_all_2d)THEN
4581	klimit = 1
4582	ELSE
4583	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4584	ASSOCIATED(list(ifield)%i3dptr) )THEN
4585	klimit=jpk
4586	ELSE
4587	klimit = 1
4588	END IF
4589	END IF
4590
4591	IF(field_is_real)THEN
4592	ztab( 1 , jjr, 1:klimit) = 0._wp
4593	ztab(jpiglo, jjr, 1:klimit) = 0._wp
4594	ELSE
4595	iztab( 1 , jji, 1:klimit) = 0
4596	iztab(jpiglo, jji, 1:klimit) = 0
4597	END IF
4598
4599	SELECT CASE ( list(ifield)%grid )
4600
4601	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
4602
4603	IF(field_is_real)THEN
4604	#if defined key_z_first
4605	DO ji = 2, jpiglo/2
4606	ijt = jpiglo-ji+2
4607	DO jk = 1,klimit,1
4608	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4609	END DO
4610	END DO
4611	DO ji = jpiglo/2+1, jpiglo
4612	ijt = jpiglo-ji+2
4613	DO jk = 1,klimit,1
4614	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4615	ztab(ji,jjr, jk) = psgn * ztab(ijt,jjr-2,jk)
4616	END DO
4617	END DO
4618	#else
4619	DO jk = 1,klimit,1
4620	DO ji = 2, jpiglo/2
4621	ijt = jpiglo-ji+2
4622	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4623	END DO
4624	DO ji = jpiglo/2+1, jpiglo
4625	ijt = jpiglo-ji+2
4626	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4627	ztab(ji,jjr, jk) = psgn * ztab(ijt,jjr-2,jk)
4628	END DO
4629	END DO
4630	#endif
4631	ELSE
4632	#if defined key_z_first
4633	DO ji = 2, jpiglo
4634	ijt = jpiglo-ji+2
4635	DO jk=1,klimit,1
4636	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4637	END DO
4638	END DO
4639	DO ji = jpiglo/2+1, jpiglo
4640	ijt = jpiglo-ji+2
4641	DO jk=1,klimit,1
4642	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4643	END DO
4644	END DO
4645	#else
4646	DO jk=1,klimit,1
4647	DO ji = 2, jpiglo
4648	ijt = jpiglo-ji+2
4649	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4650	END DO
4651	DO ji = jpiglo/2+1, jpiglo
4652	ijt = jpiglo-ji+2
4653	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4654	END DO
4655	END DO
4656	#endif
4657	END IF
4658
4659	CASE ( 'U' ) ! U-point
4660
4661	IF(field_is_real)THEN
4662	#if defined key_z_first
4663	DO ji = 1, jpiglo-1
4664	iju = jpiglo-ji+1
4665	DO jk=1,klimit,1
4666	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk)
4667	END DO
4668	END DO
4669	DO ji = jpiglo/2, jpiglo-1
4670	iju = jpiglo-ji+1
4671	DO jk=1,klimit,1
4672	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4673	END DO
4674	END DO
4675	#else
4676	DO jk=1,klimit,1
4677	DO ji = 1, jpiglo-1
4678	iju = jpiglo-ji+1
4679	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk)
4680	END DO
4681	DO ji = jpiglo/2, jpiglo-1
4682	iju = jpiglo-ji+1
4683	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4684	END DO
4685	END DO
4686	#endif
4687	ELSE
4688	#if defined key_z_first
4689	DO ji = 1, jpiglo-1
4690	iju = jpiglo-ji+1
4691	DO jk=1,klimit,1
4692	iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk)
4693	END DO
4694	END DO
4695	DO ji = jpiglo/2, jpiglo-1
4696	iju = jpiglo-ji+1
4697	DO jk=1,klimit,1
4698	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
4699	END DO
4700	END DO
4701	#else
4702	DO jk=1,klimit,1
4703	DO ji = 1, jpiglo-1
4704	iju = jpiglo-ji+1
4705	iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk)
4706	END DO
4707	DO ji = jpiglo/2, jpiglo-1
4708	iju = jpiglo-ji+1
4709	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
4710	END DO
4711	END DO
4712	#endif
4713	END IF
4714
4715	CASE ( 'V' ) ! V-point
4716
4717	IF(field_is_real)THEN
4718	#if defined key_z_first
4719	DO ji = 2, jpiglo
4720	ijt = jpiglo-ji+2
4721	DO jk=1,klimit,1
4722	#else
4723	DO jk=1,klimit,1
4724	DO ji = 2, jpiglo
4725	ijt = jpiglo-ji+2
4726	#endif
4727	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-2,jk)
4728	ztab(ji,jjr ,jk) = psgn * ztab(ijt,jjr-3,jk)
4729	END DO
4730	END DO
4731	ELSE
4732	#if defined key_z_first
4733	DO ji = 2, jpiglo
4734	ijt = jpiglo-ji+2
4735	DO jk=1,klimit,1
4736	#else
4737	DO jk=1,klimit,1
4738	DO ji = 2, jpiglo
4739	ijt = jpiglo-ji+2
4740	#endif
4741	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-2,jk)
4742	iztab(ji,jji ,jk) = isgn * iztab(ijt,jji-3,jk)
4743	END DO
4744	END DO
4745	END IF
4746
4747	CASE ( 'F' , 'G' ) ! F-point
4748
4749	IF(field_is_real)THEN
4750	#if defined key_z_first
4751	DO ji = 1, jpiglo-1
4752	iju = jpiglo-ji+1
4753	DO jk=1,klimit,1
4754	#else
4755	DO jk=1,klimit,1
4756	DO ji = 1, jpiglo-1
4757	iju = jpiglo-ji+1
4758	#endif
4759	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-2,jk)
4760	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-3,jk)
4761	END DO
4762	END DO
4763	ELSE
4764	#if defined key_z_first
4765	DO ji = 1, jpiglo-1
4766	iju = jpiglo-ji+1
4767	DO jk=1,klimit,1
4768	#else
4769	DO jk=1,klimit,1
4770	DO ji = 1, jpiglo-1
4771	iju = jpiglo-ji+1
4772	#endif
4773	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-2,jk)
4774	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-3,jk)
4775	END DO
4776	END DO
4777	END IF
4778
4779	CASE ( 'I' ) ! ice U-V point
4780
4781	IF(field_is_real)THEN
4782	#if defined key_z_first
4783	DO jk=1,klimit,1
4784	ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk)
4785	END DO
4786	DO ji = 3, jpiglo
4787	iju = jpiglo - ji + 3
4788	DO jk=1,klimit,1
4789	#else
4790	DO jk=1,klimit,1
4791	ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk)
4792	DO ji = 3, jpiglo
4793	iju = jpiglo - ji + 3
4794	#endif
4795	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk)
4796	END DO
4797	END DO
4798	ELSE
4799	#if defined key_z_first
4800	DO jk=1,klimit,1
4801	iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk)
4802	END DO
4803	DO ji = 3, jpiglo
4804	iju = jpiglo - ji + 3
4805	DO jk=1,klimit,1
4806	#else
4807	DO jk=1,klimit,1
4808	iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk)
4809	DO ji = 3, jpiglo
4810	iju = jpiglo - ji + 3
4811	#endif
4812	iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk)
4813	END DO
4814	END DO
4815	END IF
4816
4817	END SELECT
4818
4819	! Move to the next set of ijpj rows corresponding to the next field
4820	jjr = jjr + ijpj
4821	jji = jji + ijpj
4822
4823	END DO ! Loop over fields
4824
4825	CASE ( 5, 6 ) ! * North fold F-point pivot
4826
4827	DO ifield=1, nfields, 1
4828
4829	! Set-up stuff dependent on whether this field is real or integer
4830	field_is_real = .FALSE.
4831	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4832	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
4833
4834	isgn = list(ifield)%isgn
4835	psgn=REAL(isgn, wp)
4836
4837	! Set up stuff dependent on whether this field is 2- or 3-dimensional
4838	IF(fields_all_3d)THEN
4839	klimit=jpk
4840	ELSE IF(fields_all_2d)THEN
4841	klimit = 1
4842	ELSE
4843	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4844	ASSOCIATED(list(ifield)%i3dptr) )THEN
4845	klimit=jpk
4846	ELSE
4847	klimit = 1
4848	END IF
4849	END IF
4850
4851	IF(field_is_real)THEN
4852	DO jk = 1, klimit, 1
4853	ztab( 1 ,jjr,jk) = 0.0_wp
4854	ztab(jpiglo,jjr,jk) = 0.0_wp
4855	END DO
4856	ELSE
4857	DO jk = 1, klimit, 1
4858	iztab( 1 ,jji,jk) = 0
4859	iztab(jpiglo,jji,jk) = 0
4860	END DO
4861	END IF
4862
4863	SELECT CASE ( list(ifield)%grid )
4864
4865	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
4866
4867	IF(field_is_real)THEN
4868	#if defined key_z_first
4869	DO ji = 1, jpiglo
4870	ijt = jpiglo-ji+1
4871	DO jk = 1,klimit,1
4872	#else
4873	DO jk = 1,klimit,1
4874	DO ji = 1, jpiglo
4875	ijt = jpiglo-ji+1
4876	#endif
4877	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-1,jk)
4878	END DO
4879	END DO
4880	ELSE
4881	#if defined key_z_first
4882	DO ji = 1, jpiglo
4883	ijt = jpiglo-ji+1
4884	DO jk=1,klimit,1
4885	#else
4886	DO jk=1,klimit,1
4887	DO ji = 1, jpiglo
4888	ijt = jpiglo-ji+1
4889	#endif
4890	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-1,jk)
4891	END DO
4892	END DO
4893	END IF
4894
4895	CASE ( 'U' ) ! U-point
4896
4897	IF(field_is_real)THEN
4898	#if defined key_z_first
4899	DO ji = 1, jpiglo-1
4900	iju = jpiglo-ji
4901	DO jk=1,klimit,1
4902	#else
4903	DO jk=1,klimit,1
4904	DO ji = 1, jpiglo-1
4905	iju = jpiglo-ji
4906	#endif
4907	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk)
4908	END DO
4909	END DO
4910	ELSE
4911	#if defined key_z_first
4912	DO ji = 1, jpiglo-1
4913	iju = jpiglo-ji
4914	DO jk=1,klimit,1
4915	#else
4916	DO jk=1,klimit,1
4917	DO ji = 1, jpiglo-1
4918	iju = jpiglo-ji
4919	#endif
4920	iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk)
4921	END DO
4922	END DO
4923	END IF
4924
4925	CASE ( 'V' ) ! V-point
4926	IF(field_is_real)THEN
4927	#if defined key_z_first
4928	DO ji = 1, jpiglo
4929	ijt = jpiglo-ji+1
4930	DO jk=1,klimit,1
4931	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4932	END DO
4933	END DO
4934	DO ji = jpiglo/2+1, jpiglo
4935	ijt = jpiglo-ji+1
4936	DO jk=1,klimit,1
4937	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4938	END DO
4939	END DO
4940	#else
4941	DO jk=1,klimit,1
4942	DO ji = 1, jpiglo
4943	ijt = jpiglo-ji+1
4944	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4945	END DO
4946	DO ji = jpiglo/2+1, jpiglo
4947	ijt = jpiglo-ji+1
4948	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4949	END DO
4950	END DO
4951	#endif
4952	ELSE
4953	#if defined key_z_first
4954	DO ji = 1, jpiglo
4955	ijt = jpiglo-ji+1
4956	DO jk=1,klimit,1
4957	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4958	END DO
4959	END DO
4960	DO ji = jpiglo/2+1, jpiglo
4961	ijt = jpiglo-ji+1
4962	DO jk=1,klimit,1
4963	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4964	END DO
4965	END DO
4966	#else
4967	DO jk=1,klimit,1
4968	DO ji = 1, jpiglo
4969	ijt = jpiglo-ji+1
4970	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4971	END DO
4972	DO ji = jpiglo/2+1, jpiglo
4973	ijt = jpiglo-ji+1
4974	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4975	END DO
4976	END DO
4977	#endif
4978	END IF
4979
4980	CASE ( 'F' , 'G' ) ! F-point
4981
4982	IF(field_is_real)THEN
4983	#if defined key_z_first
4984
4985	DO ji = 1, jpiglo-1
4986	iju = jpiglo-ji
4987	DO jk=1,klimit,1
4988	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-2,jk)
4989	END DO
4990	END DO
4991	DO ji = jpiglo/2+1, jpiglo-1
4992	iju = jpiglo-ji
4993	DO jk=1,klimit,1
4994	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4995	END DO
4996	END DO
4997	#else
4998	DO jk=1,klimit,1
4999	DO ji = 1, jpiglo-1
5000	iju = jpiglo-ji
5001	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-2,jk)
5002	END DO
5003	DO ji = jpiglo/2+1, jpiglo-1
5004	iju = jpiglo-ji
5005	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
5006	END DO
5007	END DO
5008	#endif
5009	ELSE
5010	#if defined key_z_first
5011	DO ji = 1, jpiglo-1
5012	iju = jpiglo-ji
5013	DO jk=1,klimit,1
5014	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-2,jk)
5015	END DO
5016	END DO
5017	DO ji = jpiglo/2+1, jpiglo-1
5018	iju = jpiglo-ji
5019	DO jk=1,klimit,1
5020	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
5021	END DO
5022	END DO
5023	#else
5024	DO jk=1,klimit,1
5025	DO ji = 1, jpiglo-1
5026	iju = jpiglo-ji
5027	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-2,jk)
5028	END DO
5029	DO ji = jpiglo/2+1, jpiglo-1
5030	iju = jpiglo-ji
5031	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
5032	END DO
5033	END DO
5034	#endif
5035	END IF
5036
5037	CASE ( 'I' ) ! ice U-V point
5038
5039	IF(field_is_real)THEN
5040	#if defined key_z_first
5041	DO jk=1,klimit,1
5042	ztab( 2 ,jjr,jk) = 0._wp
5043	END DO
5044	DO ji = 2 , jpiglo-1
5045	ijt = jpiglo - ji + 2
5046	DO jk=1,klimit,1
5047	ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + &
5048	psgn * ztab(ijt,jjr-1,jk) )
5049	END DO
5050	END DO
5051	#else
5052	DO jk=1,klimit,1
5053	ztab( 2 ,jjr,jk) = 0._wp
5054	DO ji = 2 , jpiglo-1
5055	ijt = jpiglo - ji + 2
5056	ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + &
5057	psgn * ztab(ijt,jjr-1,jk) )
5058	END DO
5059	END DO
5060	#endif
5061	ELSE
5062	#if defined key_z_first
5063	DO jk=1,klimit,1
5064	iztab( 2 ,jji,jk) = 0
5065	END DO
5066	DO ji = 2 , jpiglo-1
5067	ijt = jpiglo - ji + 2
5068	DO jk=1,klimit,1
5069	iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + &
5070	isgn * iztab(ijt,jji-1,jk) )
5071	END DO
5072	END DO
5073	#else
5074	DO jk=1,klimit,1
5075	iztab( 2 ,jji,jk) = 0
5076	DO ji = 2 , jpiglo-1
5077	ijt = jpiglo - ji + 2
5078	iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + &
5079	isgn * iztab(ijt,jji-1,jk) )
5080	END DO
5081	END DO
5082	#endif
5083	END IF
5084
5085	END SELECT
5086
5087	! Move to the next set of ijpj rows corresponding to the next field
5088	jjr = jjr + ijpj
5089	jji = jji + ijpj
5090	END DO ! loop over fields
5091
5092	CASE DEFAULT ! * closed : the code probably never go through
5093
5094	DO ifield=1, nfields, 1
5095
5096	! Set-up stuff dependent on whether this field is real or integer
5097	field_is_real = .FALSE.
5098	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
5099	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
5100
5101	! Set up stuff dependent on whether this field is
5102	! 2- or 3-dimensional
5103	IF(fields_all_3d)THEN
5104	klimit=jpk
5105	ELSE IF(fields_all_2d)THEN
5106	klimit = 1
5107	ELSE
5108	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
5109	ASSOCIATED(list(ifield)%i3dptr) )THEN
5110	klimit=jpk
5111	ELSE
5112	klimit = 1
5113	END IF
5114	END IF
5115
5116	SELECT CASE ( list(ifield)%grid)
5117
5118	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5119	IF(field_is_real)THEN
5120	#if defined key_z_first
5121	DO ii = 1, jpiglo, 1
5122	DO jk = 1, klimit, 1
5123	#else
5124	DO jk = 1, klimit, 1
5125	DO ii = 1, jpiglo, 1
5126	#endif
5127	ztab(ii, 1 , jk) = 0_wp
5128	ztab(ii,jjr, jk) = 0_wp
5129	END DO
5130	END DO
5131	ELSE
5132	#if defined key_z_first
5133	DO ii = 1, jpiglo, 1
5134	DO jk = 1, klimit, 1
5135	#else
5136	DO jk = 1, klimit, 1
5137	DO ii = 1, jpiglo, 1
5138	#endif
5139	iztab(ii, 1 ,jk) = 0
5140	iztab(ii,jji,jk) = 0
5141	END DO
5142	END DO
5143	END IF
5144
5145	CASE ( 'F' ) ! F-point
5146	IF(field_is_real)THEN
5147	ztab(:,jjr,1:klimit) = 0_wp
5148	ELSE
5149	iztab(:,jji,1:klimit) = 0
5150	END IF
5151
5152	CASE ( 'I' ) ! ice U-V point
5153	IF(field_is_real)THEN
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	ztab(ii, 1 ,jk) = 0_wp
5162	ztab(ii,jjr,jk) = 0_wp
5163	END DO
5164	END DO
5165	ELSE
5166	#if defined key_z_first
5167	DO ii = 1, jpiglo, 1
5168	DO jk = 1, klimit, 1
5169	#else
5170	DO jk = 1, klimit, 1
5171	DO ii = 1, jpiglo, 1
5172	#endif
5173	iztab(ii, 1 ,jk) = 0
5174	iztab(ii,jji,jk) = 0
5175	END DO
5176	END DO
5177	END IF
5178
5179	END SELECT
5180
5181	! Move to the next set of ijpj rows corresponding to the next field
5182	jjr = jjr + ijpj
5183	jji = jji + ijpj
5184	END DO ! loop over fields
5185
5186	END SELECT
5187
5188
5189	! End of slab
5190	! ===========
5191
5192	!! Scatter back to original array(s)
5193	!!$ DO jr = 1, ndim_rank_north
5194	!!$ jproc=nrank_north(jr)+1
5195	!!$ ildi=nldit (jproc)
5196	!!$ ilei=nleit (jproc)
5197	!!$ iilb=pielb(jproc)
5198	!!$ IF(.NOT. fields_all_int)THEN
5199	!!$ znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5200	!!$ ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5201	!!$ END IF
5202	!!$ IF(.NOT. fields_all_real)THEN
5203	!!$ iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5204	!!$ iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5205	!!$ END IF
5206	!!$ END DO
5207
5208	IF(fields_all_int)THEN
5209
5210	DO jr = 1, ndim_rank_north
5211	jproc=nrank_north(jr)+1
5212	ildi=nldit (jproc)
5213	ilei=nleit (jproc)
5214	iilb=pielb(jproc)
5215	! ARPDBG - make loop ordering explicit for performance?
5216	iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5217	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5218	END DO
5219
5220	ELSE IF(fields_all_real)THEN
5221
5222	DO jr = 1, ndim_rank_north
5223	jproc=nrank_north(jr)+1
5224	ildi=nldit (jproc)
5225	ilei=nleit (jproc)
5226	iilb=pielb(jproc)
5227	! ARPDBG - make loop ordering explicit for performance?
5228	znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5229	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5230	END DO
5231
5232	ELSE ! Have some real and some integer fields
5233
5234	DO jr = 1, ndim_rank_north
5235	jproc=nrank_north(jr)+1
5236	ildi=nldit (jproc)
5237	ilei=nleit (jproc)
5238	iilb=pielb(jproc)
5239	! ARPDBG - make loop ordering explicit for performance?
5240	znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5241	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5242	iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5243	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5244	END DO
5245
5246	END IF
5247
5248	ENDIF ! only done on proc 0 of ncomm_north
5249
5250	CALL prof_region_end(ARPNORTHAPPLYSYMM, iprofStat)
5251
5252	CALL prof_region_begin(NORTHLISTSCATTER, "NorthListScatter", iprofStat)
5253
5254	IF ( npolj /= 0 ) THEN
5255	IF(.NOT. fields_all_int)THEN
5256	itaille=nwidthmaxishiftrklimit
5257	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
5258	znorthloc, itaille,MPI_DOUBLE_PRECISION, &
5259	0, ncomm_north,ierr)
5260	END IF
5261	IF(.NOT. fields_all_real)THEN
5262	itaille=nwidthmaxishiftiklimit
5263	CALL MPI_SCATTER(iznorthgloio,itaille,MPI_INTEGER, &
5264	iznorthloc, itaille,MPI_INTEGER, &
5265	0, ncomm_north,ierr)
5266
5267	END IF
5268	ENDIF
5269
5270	! put back the last ijpj jlines of each field
5271	ishiftr = 0
5272	ishifti = 0
5273	DO ifield=1,nfields,1
5274
5275	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
5276	DO ij = 1, ijpj, 1
5277	jj = nlcj - ijpj + ij
5278	list(ifield)%r2dptr(nldi:nlei,jj)= znorthloc(nldi:nlei,ij+ishiftr,1)
5279	END DO
5280	ishiftr = ishiftr + ijpj
5281	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
5282	#if defined key_z_first
5283	DO ij = 1, ijpj, 1
5284	jj = nlcj - ijpj + ij
5285	DO jk = 1, jpk
5286	#else
5287	DO jk = 1, jpk
5288	DO ij = 1, ijpj, 1
5289	jj = nlcj - ijpj + ij
5290	#endif
5291	! ARPDBG Make loop over i explicit for performance?
5292	list(ifield)%r3dptr(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij+ishiftr,jk)
5293	END DO
5294	END DO
5295	ishiftr = ishiftr + ijpj
5296	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
5297	DO ij = 1, ijpj, 1
5298	jj = nlcj - ijpj + ij
5299	list(ifield)%i2dptr(nldi:nlei,jj)= iznorthloc(nldi:nlei,ij+ishifti,1)
5300	END DO
5301	ishifti = ishifti + ijpj
5302	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
5303	#if defined key_z_first
5304	DO ij = 1, ijpj, 1
5305	jj = nlcj - ijpj + ij
5306	DO jk = 1, jpk
5307	#else
5308	DO jk = 1, jpk
5309	DO ij = 1, ijpj, 1
5310	jj = nlcj - ijpj + ij
5311	#endif
5312	! ARPDBG Make loop over i explicit for performance?
5313	list(ifield)%i3dptr(nldi:nlei,jj,jk)= iznorthloc(nldi:nlei,ij+ishifti,jk)
5314	END DO
5315	END DO
5316	ishifti = ishifti + ijpj
5317	END IF
5318	END DO ! loop over fields
5319
5320	CALL prof_region_end(NORTHLISTSCATTER, iprofStat)
5321
5322	#endif /* key_mpp_mpi */
5323
5324	CALL prof_region_end(ARPNORTHLISTCOMMS, iprofStat)
5325
5326	END SUBROUTINE mpp_lbc_north_list
5327
5328	!============================================================================
5329
5330	SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn)
5331	!!---------------------------------------------------------------------
5332	!! * routine mpp_lbc_north_2d *
5333	!!
5334	!! ** Purpose :
5335	!! Ensure proper north fold horizontal bondary condition in mpp
5336	!! configuration in case of jpn1 > 1 (for 2d array )
5337	!!
5338	!! ** Method :
5339	!! Gather the 4 northern lines of the global domain on 1 processor and
5340	!! apply lbc north-fold on this sub array. Then scatter the fold array
5341	!! back to the processors.
5342	!!
5343	!! History :
5344	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5345	!! from lbc routine
5346	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding
5347	!! rules of lbc_lnk
5348	!!----------------------------------------------------------------------
5349	USE par_oce, ONLY : jpni, jpi, jpj
5350	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
5351	nwidthmax
5352	USE mapcomm_mod, ONLY : pielb, piesub
5353	USE lib_mpp, ONLY : ctl_stop
5354	USE arpdebugging, ONLY: dump_array
5355	IMPLICIT none
5356	!! * Arguments
5357	CHARACTER(len=1), INTENT( in ) :: &
5358	cd_type ! nature of pt2d grid-points
5359	! ! = T , U , V , F or W gridpoints
5360	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
5361	pt2d ! 2D array on which the boundary condition is applied
5362	REAL(wp), INTENT( in ) :: &
5363	psgn ! control of the sign change
5364	! ! = -1. , the sign is changed if north fold boundary
5365	! ! = 1. , the sign is kept if north fold boundary
5366
5367	!! * Local declarations
5368
5369	INTEGER :: ijpj
5370	INTEGER :: ji, jj, jr, jproc
5371	INTEGER :: ierr
5372	INTEGER :: ildi,ilei,iilb
5373	INTEGER :: ijpjm1,ij,ijt,iju
5374	INTEGER :: itaille
5375
5376	REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: ztab2
5377	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio2
5378	REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: znorthloc2
5379	!!----------------------------------------------------------------------
5380	!! OPA 8.5, LODYC-IPSL (2002)
5381	!!----------------------------------------------------------------------
5382	! If we get in this routine it's because : North fold condition and mpp
5383	! with more than one PE across i : we deal only with the North condition
5384
5385	! Set local from public PARAMETER
5386	ijpj = num_nfold_rows
5387
5388	CALL prof_region_begin(ARPNORTHCOMMS2D, "North2D", iprofStat)
5389
5390	#if defined key_mpp_mpi
5391
5392	IF(.not. ALLOCATED(ztab2))THEN
5393
5394	ALLOCATE(ztab2(jpiglo,ijpj), &
5395	znorthgloio2(nwidthmax,ijpj,ndim_rank_north), &
5396	znorthloc2(nwidthmax,ijpj), &
5397	STAT=ierr)
5398	IF(ierr .ne. 0)THEN
5399	CALL ctl_stop('STOP','mpp_lbc_north_2d: memory allocation failed' )
5400	END IF
5401	END IF
5402
5403	! 0. Sign setting
5404	! ---------------
5405
5406	ijpjm1=ijpj-1
5407
5408	! put the last ijpj jlines of pt2d into znorthloc2
5409	znorthloc2(:,:) = 0_wp ! because of padding for nwidthmax
5410
5411	! jeub is the upper j limit of current domain in global coords
5412	!
5413	! \|======================= jpjglo ^
5414	! <Trimmed> \| /\|\
5415	! \|----------------------- jpjglo-1 \|
5416	! \| \|
5417	! \|---------jeub--------------------------------
5418	! \| \| j
5419	! \|--------------------------------------------
5420	! \| \| \|
5421	! \|-------------------------------------------- \|
5422	!
5423	! No. of trimmed rows = jpjglo - jeub
5424	! No. of valid rows for n-fold = ijpj - <no. trimmed rows>
5425	! = ijpj - jpjglo + jeub
5426	! Need an iterator that ends with max value ijpj and has (ijpj-jpjglo+jeub)
5427	! distinct values so start point must be:
5428	! ij_start = ijpj - (ijpj-jpjglo+jeub) + 1 = jpjglo - jeub + 1
5429	! => if jeub == jpjglo then we recover a starting value of 1.
5430	! if jeub == jpjglo - 10 then ij_start = 11 so no loop iterations
5431	! will be performed.
5432
5433	#if defined NO_NFOLD_GATHER
5434	! Post receives for other PE's north-fold data
5435	DO iproc = 1, ndim_rank_north, 1
5436
5437	IF( iproc-1 == nrank_north(iproc) ) CYCLE ! Skip this PE
5438
5439	CALL MPI_IRecv(znorthgloio2(), north_pts(iproc), MPI_DOUBLE_PRECISION, &
5440	nrank_north(iproc), iproc, tag, ncomm_north, &
5441	nexch_flag(iproc) )
5442	END DO
5443	#endif
5444
5445	DO ij = jpjglo - jeub + 1, ijpj, 1
5446
5447	jj = nlcj - ijpj + ij
5448	znorthloc2(nldi:nlei,ij)=pt2d(nldi:nlei,jj)
5449	END DO
5450
5451	! CALL dump_array(0,'znorthloc2',znorthloc2,withHalos=.TRUE.,toGlobal=.FALSE.)
5452
5453	IF (npolj /= 0 ) THEN
5454	! Build in proc 0 of ncomm_north the znorthgloio2
5455	znorthgloio2(:,:,:) = 0_wp
5456	itaille=nwidthmax*ijpj
5457	CALL MPI_GATHER(znorthloc2,itaille,MPI_DOUBLE_PRECISION, &
5458	znorthgloio2,itaille,MPI_DOUBLE_PRECISION, &
5459	0, ncomm_north, ierr)
5460
5461	ENDIF
5462
5463	IF (narea == north_root+1 ) THEN
5464	! recover the global north array
5465	! ztab2 has full width of global domain
5466	ztab2(:,:) = 0_wp
5467
5468	DO jr = 1, ndim_rank_north
5469	jproc=nrank_north(jr)+1
5470	ildi=nldit(jproc)
5471	ilei=nleit(jproc)
5472	iilb=pielb(jproc)
5473	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)= &
5474	znorthgloio2(ildi:ilei,1:ijpj,jr)
5475	END DO
5476
5477	! CALL dump_array(0,'ztab2',ztab2,withHalos=.TRUE.,toGlobal=.FALSE.)
5478
5479	! 2. North-Fold boundary conditions
5480	! ----------------------------------
5481
5482	SELECT CASE ( npolj )
5483
5484	CASE ( 3, 4 ) ! * North fold T-point pivot
5485
5486	ztab2( 1 ,ijpj) = 0._wp
5487	ztab2(jpiglo,ijpj) = 0._wp
5488
5489	SELECT CASE ( cd_type )
5490
5491	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
5492	DO ji = 2, jpiglo
5493	ijt = jpiglo-ji+2
5494	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2)
5495	END DO
5496	DO ji = jpiglo/2+1, jpiglo
5497	ijt = jpiglo-ji+2
5498	ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1)
5499	END DO
5500
5501	CASE ( 'U' ) ! U-point
5502	DO ji = 1, jpiglo-1
5503	iju = jpiglo-ji+1
5504	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-2)
5505	END DO
5506	DO ji = jpiglo/2, jpiglo-1
5507	iju = jpiglo-ji+1
5508	ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1)
5509	END DO
5510
5511	CASE ( 'V' ) ! V-point
5512	DO ji = 2, jpiglo
5513	ijt = jpiglo-ji+2
5514	ztab2(ji,ijpj-1) = psgn * ztab2(ijt,ijpj-2)
5515	ztab2(ji,ijpj ) = psgn * ztab2(ijt,ijpj-3)
5516	END DO
5517
5518	CASE ( 'F' , 'G' ) ! F-point
5519	DO ji = 1, jpiglo-1
5520	iju = jpiglo-ji+1
5521	ztab2(ji,ijpj-1) = psgn * ztab2(iju,ijpj-2)
5522	ztab2(ji,ijpj ) = psgn * ztab2(iju,ijpj-3)
5523	END DO
5524
5525	CASE ( 'I' ) ! ice U-V point
5526	ztab2(2,ijpj) = psgn * ztab2(3,ijpj-1)
5527	DO ji = 3, jpiglo
5528	iju = jpiglo - ji + 3
5529	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1)
5530	END DO
5531
5532	END SELECT
5533
5534	CASE ( 5, 6 ) ! * North fold F-point pivot
5535
5536	ztab2( 1 ,ijpj) = 0._wp
5537	ztab2(jpiglo,ijpj) = 0._wp
5538
5539	SELECT CASE ( cd_type )
5540
5541	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
5542	DO ji = 1, jpiglo
5543	ijt = jpiglo-ji+1
5544	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-1)
5545	END DO
5546
5547	CASE ( 'U' ) ! U-point
5548	DO ji = 1, jpiglo-1
5549	iju = jpiglo-ji
5550	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1)
5551	END DO
5552
5553	CASE ( 'V' ) ! V-point
5554	DO ji = 1, jpiglo
5555	ijt = jpiglo-ji+1
5556	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2)
5557	END DO
5558	DO ji = jpiglo/2+1, jpiglo
5559	ijt = jpiglo-ji+1
5560	ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1)
5561	END DO
5562
5563	CASE ( 'F' , 'G' ) ! F-point
5564	DO ji = 1, jpiglo-1
5565	iju = jpiglo-ji
5566	ztab2(ji,ijpj ) = psgn * ztab2(iju,ijpj-2)
5567	END DO
5568	DO ji = jpiglo/2+1, jpiglo-1
5569	iju = jpiglo-ji
5570	ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1)
5571	END DO
5572
5573	CASE ( 'I' ) ! ice U-V point
5574	ztab2( 2 ,ijpj) = 0.e0
5575	DO ji = 2 , jpiglo-1
5576	ijt = jpiglo - ji + 2
5577	ztab2(ji,ijpj)= 0.5 * ( ztab2(ji,ijpj-1) + psgn * ztab2(ijt,ijpj-1) )
5578	END DO
5579
5580	END SELECT
5581
5582	CASE DEFAULT ! * closed : the code probably never go through
5583
5584	SELECT CASE ( cd_type)
5585
5586	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5587	ztab2(:, 1 ) = 0._wp
5588	ztab2(:,ijpj) = 0._wp
5589
5590	CASE ( 'F' ) ! F-point
5591	ztab2(:,ijpj) = 0._wp
5592
5593	CASE ( 'I' ) ! ice U-V point
5594	ztab2(:, 1 ) = 0._wp
5595	ztab2(:,ijpj) = 0._wp
5596
5597	END SELECT
5598
5599	END SELECT
5600
5601	! End of slab
5602	! ===========
5603
5604	!! Scatter back to pt2d
5605	DO jr = 1, ndim_rank_north
5606	jproc=nrank_north(jr)+1
5607	ildi=nldit (jproc)
5608	ilei=nleit (jproc)
5609	iilb=pielb(jproc)
5610	znorthgloio2(ildi:ilei,1:ijpj,jr)= &
5611	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
5612	END DO
5613
5614	ENDIF ! only done on proc 0 of ncomm_north
5615
5616	IF ( npolj /= 0 ) THEN
5617	itaille=nwidthmax*ijpj
5618	CALL MPI_SCATTER(znorthgloio2,itaille,MPI_DOUBLE_PRECISION, &
5619	znorthloc2, itaille,MPI_DOUBLE_PRECISION, &
5620	0,ncomm_north,ierr)
5621	ENDIF
5622
5623	! Put the last ijpj jlines of pt2d into znorthloc2 while allowing
5624	! for any trimming of domain (see earlier comments and diagram)
5625	DO ij = jpjglo - jeub + 1, ijpj, 1
5626	jj = nlcj - ijpj + ij
5627	pt2d(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
5628	END DO
5629
5630	#endif /* key_mpp_mpi */
5631
5632	CALL prof_region_end(ARPNORTHCOMMS2D, iprofStat)
5633
5634	END SUBROUTINE mpp_lbc_north_2d
5635
5636	!====================================================================
5637
5638	SUBROUTINE mpp_lbc_north_i2d ( ib2, cd_type, isgn)
5639	!!---------------------------------------------------------------------
5640	!! * routine mpp_lbc_north_2d *
5641	!!
5642	!! ** Purpose :
5643	!! Ensure proper north fold horizontal bondary condition in mpp
5644	!! configuration in case of jpn1 > 1 (for 2d array )
5645	!!
5646	!! ** Method :
5647	!! Gather the 4 northern lines of the global domain on 1 processor and
5648	!! apply lbc north-fold on this sub array. Then scatter the fold array
5649	!! back to the processors.
5650	!!
5651	!! History :
5652	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5653	!! from lbc routine
5654	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp,
5655	!! coding rules of lbc_lnk
5656	!!----------------------------------------------------------------------
5657	USE par_oce, ONLY : jpni, jpi, jpj
5658	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, &
5659	nlcj, nwidthmax
5660	USE mapcomm_mod, ONLY : pielb, piesub
5661	USE lib_mpp, ONLY : ctl_stop
5662	IMPLICIT none
5663	!! * Arguments
5664	CHARACTER(len=1), INTENT( in ) :: &
5665	cd_type ! nature of ib2 grid-points
5666	! ! = T , U , V , F or W gridpoints
5667	INTEGER, DIMENSION(jpi,jpj), INTENT( inout ) :: &
5668	ib2 ! 2D array on which the boundary condition is applied
5669	INTEGER, INTENT( in ) :: &
5670	isgn ! control of the sign change
5671	! ! = -1. , the sign is changed if north fold boundary
5672	! ! = 1. , the sign is kept if north fold boundary
5673
5674	!! * Local declarations
5675
5676	INTEGER :: ijpj
5677	INTEGER :: ji, jj, jr, jproc
5678	INTEGER :: ierr
5679	INTEGER :: ildi,ilei,iilb
5680	INTEGER :: ijpjm1,ij,ijt,iju
5681	INTEGER :: itaille
5682
5683	INTEGER, DIMENSION(:,:), ALLOCATABLE :: ztab2
5684	INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio2
5685	INTEGER, DIMENSION(:,:), ALLOCATABLE :: znorthloc2
5686	!!----------------------------------------------------------------------
5687	!! OPA 8.5, LODYC-IPSL (2002)
5688	!!----------------------------------------------------------------------
5689	! If we get in this routine it's because : North fold condition and mpp
5690	! with more than one PE across i : we deal only with the North condition
5691
5692	#if defined key_mpp_mpi
5693
5694	ijpj = num_nfold_rows
5695	ijpjm1=ijpj - 1
5696
5697
5698	IF(.not. ALLOCATED(ztab2))THEN
5699
5700	ALLOCATE(ztab2(jpiglo,ijpj), &
5701	znorthgloio2(nwidthmax,ijpj,jpni), &
5702	znorthloc2(nwidthmax,ijpj), &
5703	STAT=ierr)
5704	IF(ierr .ne. 0)THEN
5705	CALL ctl_stop('STOP','mpp_lbc_north_i2d: memory allocation failed')
5706	END IF
5707	END IF
5708
5709	! 0. Sign setting
5710	! ---------------
5711
5712	! Put the last ijpj jlines of ib2 into znorthloc2 while allowing
5713	! for any trimming of domain (see earlier comments and diagram in
5714	! mpp_lbc_north_2d).
5715	znorthloc2(:,:) = 0 ! because of padding for nwidthmax
5716	DO ij = jpjglo - jeub + 1, ijpj, 1
5717	jj = nlcj - ijpj + ij
5718	znorthloc2(nldi:nlei,ij)=ib2(nldi:nlei,jj)
5719	END DO
5720
5721	IF (npolj /= 0 ) THEN
5722	! Build in proc 0 of ncomm_north the znorthgloio2
5723	znorthgloio2(:,:,:) = 0
5724	itaille=nwidthmax*ijpj
5725	CALL MPI_GATHER(znorthloc2,itaille,MPI_INTEGER, &
5726	znorthgloio2,itaille,MPI_INTEGER,0,&
5727	ncomm_north,ierr)
5728	ENDIF
5729
5730	IF (narea == north_root+1 ) THEN
5731	! recover the global north array
5732	ztab2(:,:) = 0
5733
5734	DO jr = 1, ndim_rank_north
5735	jproc=nrank_north(jr)+1
5736	ildi=nldit (jproc)
5737	ilei=nleit (jproc)
5738	iilb=pielb(jproc)
5739	!WRITE (,)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',&
5740	! ildi, ilei, iilb, ijpj
5741	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) = &
5742	znorthgloio2(ildi:ilei,1:ijpj,jr)
5743	END DO
5744
5745
5746	! 2. North-Fold boundary conditions
5747	! ----------------------------------
5748
5749	SELECT CASE ( npolj )
5750
5751	CASE ( 3, 4 ) ! * North fold T-point pivot
5752
5753	ztab2( 1 ,ijpj) = 0
5754	ztab2(jpiglo,ijpj) = 0
5755
5756	SELECT CASE ( cd_type )
5757
5758	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
5759	DO ji = 2, jpiglo
5760	ijt = jpiglo-ji+2
5761	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2)
5762	END DO
5763	DO ji = jpiglo/2+1, jpiglo
5764	ijt = jpiglo-ji+2
5765	ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1)
5766	END DO
5767
5768	CASE ( 'U' ) ! U-point
5769	DO ji = 1, jpiglo-1
5770	iju = jpiglo-ji+1
5771	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-2)
5772	END DO
5773	DO ji = jpiglo/2, jpiglo-1
5774	iju = jpiglo-ji+1
5775	ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1)
5776	END DO
5777
5778	CASE ( 'V' ) ! V-point
5779	DO ji = 2, jpiglo
5780	ijt = jpiglo-ji+2
5781	ztab2(ji,ijpj-1) = isgn * ztab2(ijt,ijpj-2)
5782	ztab2(ji,ijpj ) = isgn * ztab2(ijt,ijpj-3)
5783	END DO
5784
5785	CASE ( 'F' , 'G' ) ! F-point
5786	DO ji = 1, jpiglo-1
5787	iju = jpiglo-ji+1
5788	ztab2(ji,ijpj-1) = isgn * ztab2(iju,ijpj-2)
5789	ztab2(ji,ijpj ) = isgn * ztab2(iju,ijpj-3)
5790	END DO
5791
5792	CASE ( 'I' ) ! ice U-V point
5793	ztab2(2,ijpj) = isgn * ztab2(3,ijpj-1)
5794	DO ji = 3, jpiglo
5795	iju = jpiglo - ji + 3
5796	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1)
5797	END DO
5798
5799	END SELECT
5800
5801	CASE ( 5, 6 ) ! * North fold F-point pivot
5802
5803	ztab2( 1 ,ijpj) = 0
5804	ztab2(jpiglo,ijpj) = 0
5805
5806	SELECT CASE ( cd_type )
5807
5808	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
5809	DO ji = 1, jpiglo
5810	ijt = jpiglo-ji+1
5811	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-1)
5812	END DO
5813
5814	CASE ( 'U' ) ! U-point
5815	DO ji = 1, jpiglo-1
5816	iju = jpiglo-ji
5817	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1)
5818	END DO
5819
5820	CASE ( 'V' ) ! V-point
5821	DO ji = 1, jpiglo
5822	ijt = jpiglo-ji+1
5823	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2)
5824	END DO
5825	DO ji = jpiglo/2+1, jpiglo
5826	ijt = jpiglo-ji+1
5827	ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1)
5828	END DO
5829
5830	CASE ( 'F' , 'G' ) ! F-point
5831	DO ji = 1, jpiglo-1
5832	iju = jpiglo-ji
5833	ztab2(ji,ijpj ) = isgn * ztab2(iju,ijpj-2)
5834	END DO
5835	DO ji = jpiglo/2+1, jpiglo-1
5836	iju = jpiglo-ji
5837	ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1)
5838	END DO
5839
5840	CASE ( 'I' ) ! ice U-V point
5841	ztab2( 2 ,ijpj) = 0
5842	DO ji = 2 , jpiglo-1
5843	ijt = jpiglo - ji + 2
5844	ztab2(ji,ijpj)= NINT(0.5 * ( ztab2(ji,ijpj-1) + &
5845	isgn * ztab2(ijt,ijpj-1) ))
5846	END DO
5847
5848	END SELECT
5849
5850	CASE DEFAULT ! * closed : the code probably never go through
5851
5852	SELECT CASE ( cd_type)
5853
5854	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5855	ztab2(:, 1 ) = 0
5856	ztab2(:,ijpj) = 0
5857
5858	CASE ( 'F' ) ! F-point
5859	ztab2(:,ijpj) = 0
5860
5861	CASE ( 'I' ) ! ice U-V point
5862	ztab2(:, 1 ) = 0
5863	ztab2(:,ijpj) = 0
5864
5865	END SELECT
5866
5867	END SELECT
5868
5869	! End of slab
5870	! ===========
5871
5872	!! Scatter back to ib2
5873	DO jr = 1, ndim_rank_north
5874	jproc=nrank_north(jr)+1
5875	ildi=nldit (jproc)
5876	ilei=nleit (jproc)
5877	iilb=pielb(jproc)
5878	znorthgloio2(ildi:ilei,1:ijpj,jr) = &
5879	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
5880	END DO
5881
5882	ENDIF ! only done on proc 0 of ncomm_north
5883
5884	IF ( npolj /= 0 ) THEN
5885	itaille=nwidthmax*ijpj
5886	CALL MPI_SCATTER(znorthgloio2,itaille,MPI_INTEGER, &
5887	znorthloc2, itaille,MPI_INTEGER, &
5888	0, ncomm_north, ierr)
5889	ENDIF
5890
5891	! put in the last ijpj jlines of ib2 from znorthloc2 while allowing
5892	! for any trimming of domain (see earlier comments and diagram in
5893	! mpp_lbc_north_2d).
5894	DO ij = jpjglo - jeub + 1, ijpj, 1
5895	jj = nlcj - ijpj + ij
5896	ib2(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
5897	END DO
5898	WRITE(,) 'ARPDBG: finished in mpp_lbc_north_i2d'
5899
5900	#endif /* key_mpp_mpi */
5901
5902	END SUBROUTINE mpp_lbc_north_i2d
5903
5904	!=================================================================
5905
5906	SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
5907	!!---------------------------------------------------------------------
5908	!! * routine mpp_lbc_north_3d *
5909	!!
5910	!! ** Purpose :
5911	!! Ensure proper north fold horizontal bondary condition in mpp
5912	!! configuration in case of jpn1 > 1
5913	!!
5914	!! ** Method :
5915	!! Gather the 4 northern lines of the global domain on 1 processor
5916	!! and apply lbc north-fold on this sub array. Then scatter the
5917	!! fold array back to the processors.
5918	!!
5919	!! History :
5920	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5921	!! from lbc routine
5922	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp,
5923	!! coding rules of lbc_lnk
5924	!!----------------------------------------------------------------------
5925	USE par_oce, ONLY : jpni
5926	USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, nwidthmax
5927	USE mapcomm_mod, ONLY : pielb, piesub
5928	USE lib_mpp, ONLY : ctl_stop
5929	IMPLICIT none
5930	!! * Arguments
5931	CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points
5932	! ! = T, U, V, F or W gridp'ts
5933	REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: &
5934	pt3d ! 3D array on which the boundary condition is applied
5935	REAL(wp), INTENT( in ) :: &
5936	psgn ! control of the sign change
5937	! ! = -1. , the sign is changed if north fold boundary
5938	! ! = 1. , the sign is kept if north fold boundary
5939
5940	!! * Local declarations
5941	INTEGER :: ijpj
5942	INTEGER :: ji, jj, jk, jr, jproc
5943	INTEGER :: ierr
5944	INTEGER :: ildi,ilei,iilb
5945	INTEGER :: ijpjm1,ij,ijt,iju
5946	INTEGER :: itaille
5947	!FTRANS ztab :I :I :z
5948	!FTRANS znorthgloio :I :I :z :
5949	!FTRANS znorthloc :I :I :z
5950	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab
5951	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
5952	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc
5953	!!----------------------------------------------------------------------
5954
5955	! If we get in this routine it's because : North fold condition and
5956	! mpp with more than one proc across i : we deal only with the North
5957	! condition
5958	#if defined key_mpp_mpi
5959
5960	ijpj = num_nfold_rows
5961	ijpjm1=ijpj - 1
5962
5963	IF(.not. ALLOCATED(ztab))THEN
5964
5965	ALLOCATE(ztab(jpiglo,ijpj,jpkorig), &
5966	znorthgloio(nwidthmax,ijpj,jpkorig,jpni), &
5967	znorthloc(nwidthmax,ijpj,jpkorig), &
5968	STAT=ierr)
5969	IF(ierr .ne. 0)THEN
5970	CALL ctl_stop( ' mpp_lbc_north_3d: memory allocation failed' )
5971	#if defined key_mpp_mpi
5972	CALL mpi_finalize( ierr )
5973	#endif
5974	STOP
5975	END IF
5976	END IF
5977
5978	CALL prof_region_begin(NORTH3DGATHER, "North3DGather", iprofStat)
5979
5980	! 0. Sign setting
5981	! ---------------
5982
5983	! Put the last ijpj jlines of pt3d into znorthloc while allowing
5984	! for any trimming of domain (see earlier comments and diagram in
5985	! mpp_lbc_north_2d).
5986	! Have to initialise all to zero in case chunks are missing due to domain
5987	! trimming
5988	znorthloc(:,:,:) = 0.0_wp
5989	#if defined key_z_first
5990	DO ij = jpjglo - jeub + 1, ijpj, 1
5991	jj = nlcj - ijpj + ij
5992	DO jk = 1, jpk
5993	#else
5994	DO jk = 1, jpk
5995	DO ij = jpjglo - jeub + 1, ijpj, 1
5996	jj = nlcj - ijpj + ij
5997	#endif
5998	znorthloc(nldi:nlei,ij,jk) = pt3d(nldi:nlei,jj,jk)
5999	END DO
6000	END DO
6001
6002
6003	IF (npolj /= 0 ) THEN
6004	! Build in proc 0 of ncomm_north the znorthgloio
6005
6006	#ifdef key_mpp_shmem
6007	not done : compiler error
6008	#elif defined key_mpp_mpi
6009	itaille=nwidthmaxjpkorigijpj
6010	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, &
6011	znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
6012	0,ncomm_north,ierr)
6013	#endif
6014
6015	ENDIF
6016
6017	CALL prof_region_end(NORTH3DGATHER, iprofStat)
6018
6019	CALL prof_region_begin(NORTH3DAPPSYMM, "North3DApplySymm", iprofStat)
6020
6021	IF (narea == north_root+1 ) THEN
6022	! recover the global north array
6023	ztab(:,:,:) = 0_wp
6024
6025	DO jr = 1, ndim_rank_north
6026	jproc = nrank_north(jr) + 1
6027	ildi = nldit (jproc)
6028	ilei = nleit (jproc)
6029	iilb = pielb(jproc)
6030	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = &
6031	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr)
6032	END DO
6033
6034
6035	! Horizontal slab
6036	! ===============
6037	#if defined key_z_first
6038
6039	! 2. North-Fold boundary conditions
6040	! ----------------------------------
6041
6042	SELECT CASE ( npolj )
6043
6044	CASE ( 3, 4 ) ! * North fold T-point pivot
6045
6046	DO jk = 1, jpk
6047	ztab( 1 ,ijpj,jk) = 0.0_wp
6048	ztab(jpiglo,ijpj,jk) = 0.0_wp
6049	END DO
6050
6051	SELECT CASE ( cd_type )
6052
6053	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6054	DO ji = 2, jpiglo
6055	ijt = jpiglo-ji+2
6056	DO jk = 1, jpk
6057	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6058	END DO
6059	END DO
6060	DO ji = jpiglo/2+1, jpiglo
6061	ijt = jpiglo-ji+2
6062	DO jk = 1, jpk, 1
6063	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6064	END DO
6065	END DO
6066
6067	CASE ( 'U' ) ! U-point
6068	DO ji = 1, jpiglo-1
6069	iju = jpiglo-ji+1
6070	DO jk = 1, jpk, 1
6071	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
6072	END DO
6073	END DO
6074	DO ji = jpiglo/2, jpiglo-1
6075	iju = jpiglo-ji+1
6076	DO jk = 1, jpk, 1
6077	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6078	END DO
6079	END DO
6080
6081	CASE ( 'V' ) ! V-point
6082	DO ji = 2, jpiglo
6083	ijt = jpiglo-ji+2
6084	DO jk = 1, jpk, 1
6085	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
6086	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
6087	END DO
6088	END DO
6089
6090	CASE ( 'F' , 'G' ) ! F-point
6091	DO ji = 1, jpiglo-1
6092	iju = jpiglo-ji+1
6093	DO jk = 1, jpk, 1
6094	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
6095	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
6096	END DO
6097	END DO
6098
6099	END SELECT
6100
6101	CASE ( 5, 6 ) ! * North fold F-point pivot
6102
6103	DO jk = 1, jpk, 1
6104	ztab( 1 ,ijpj,jk) = 0._wp
6105	ztab(jpiglo,ijpj,jk) = 0._wp
6106	END DO
6107
6108	SELECT CASE ( cd_type )
6109
6110	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6111	DO ji = 1, jpiglo
6112	ijt = jpiglo-ji+1
6113	DO jk = 1, jpk, 1
6114	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
6115	END DO
6116	END DO
6117
6118	CASE ( 'U' ) ! U-point
6119	DO ji = 1, jpiglo-1
6120	iju = jpiglo-ji
6121	DO jk = 1, jpk, 1
6122	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
6123	END DO
6124	END DO
6125
6126	CASE ( 'V' ) ! V-point
6127	DO ji = 1, jpiglo
6128	ijt = jpiglo-ji+1
6129	DO jk = 1, jpk, 1
6130	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6131	END DO
6132	END DO
6133	DO ji = jpiglo/2+1, jpiglo
6134	ijt = jpiglo-ji+1
6135	DO jk = 1, jpk, 1
6136	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6137	END DO
6138	END DO
6139
6140	CASE ( 'F' , 'G' ) ! F-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-2,jk)
6145	END DO
6146	END DO
6147	DO ji = jpiglo/2+1, jpiglo-1
6148	iju = jpiglo-ji
6149	DO jk = 1, jpk, 1
6150	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6151	END DO
6152	END DO
6153
6154	END SELECT
6155
6156	CASE DEFAULT ! * closed
6157
6158	SELECT CASE ( cd_type)
6159
6160	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6161	DO ji = 1, jpiglo, 1
6162	DO jk = 1, jpk, 1
6163	ztab(ji, 1 ,jk) = 0.0_wp
6164	ztab(ji,ijpj,jk) = 0.0_wp
6165	END DO
6166	END DO
6167
6168	CASE ( 'F' ) ! F-point
6169	DO ji = 1, jpiglo, 1
6170	DO jk = 1, jpk, 1
6171	ztab(ji,ijpj,jk) = 0.0_wp
6172	END DO
6173	END DO
6174
6175	END SELECT
6176
6177	END SELECT
6178
6179	! End of slab
6180	! ===========
6181	#else
6182	DO jk = 1, jpk
6183
6184
6185	! 2. North-Fold boundary conditions
6186	! ----------------------------------
6187
6188	SELECT CASE ( npolj )
6189
6190	CASE ( 3, 4 ) ! * North fold T-point pivot
6191
6192	ztab( 1 ,ijpj,jk) = 0.0_wp
6193	ztab(jpiglo,ijpj,jk) = 0.0_wp
6194
6195	SELECT CASE ( cd_type )
6196
6197	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6198	DO ji = 2, jpiglo
6199	ijt = jpiglo-ji+2
6200	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6201	END DO
6202	DO ji = jpiglo/2+1, jpiglo
6203	ijt = jpiglo-ji+2
6204	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6205	END DO
6206
6207	CASE ( 'U' ) ! U-point
6208	DO ji = 1, jpiglo-1
6209	iju = jpiglo-ji+1
6210	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
6211	END DO
6212	DO ji = jpiglo/2, jpiglo-1
6213	iju = jpiglo-ji+1
6214	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6215	END DO
6216
6217	CASE ( 'V' ) ! V-point
6218	DO ji = 2, jpiglo
6219	ijt = jpiglo-ji+2
6220	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
6221	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
6222	END DO
6223
6224	CASE ( 'F' , 'G' ) ! F-point
6225	DO ji = 1, jpiglo-1
6226	iju = jpiglo-ji+1
6227	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
6228	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
6229	END DO
6230
6231	END SELECT
6232
6233	CASE ( 5, 6 ) ! * North fold F-point pivot
6234
6235	ztab( 1 ,ijpj,jk) = 0._wp
6236	ztab(jpiglo,ijpj,jk) = 0._wp
6237
6238	SELECT CASE ( cd_type )
6239
6240	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6241	DO ji = 1, jpiglo
6242	ijt = jpiglo-ji+1
6243	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
6244	END DO
6245
6246	CASE ( 'U' ) ! U-point
6247	DO ji = 1, jpiglo-1
6248	iju = jpiglo-ji
6249	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
6250	END DO
6251
6252	CASE ( 'V' ) ! V-point
6253	DO ji = 1, jpiglo
6254	ijt = jpiglo-ji+1
6255	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6256	END DO
6257	DO ji = jpiglo/2+1, jpiglo
6258	ijt = jpiglo-ji+1
6259	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6260	END DO
6261
6262	CASE ( 'F' , 'G' ) ! F-point
6263	DO ji = 1, jpiglo-1
6264	iju = jpiglo-ji
6265	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
6266	END DO
6267	DO ji = jpiglo/2+1, jpiglo-1
6268	iju = jpiglo-ji
6269	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6270	END DO
6271
6272	END SELECT
6273
6274	CASE DEFAULT ! * closed
6275
6276	SELECT CASE ( cd_type)
6277
6278	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6279	ztab(:, 1 ,jk) = 0.0_wp
6280	ztab(:,ijpj,jk) = 0.0_wp
6281
6282	CASE ( 'F' ) ! F-point
6283	ztab(:,ijpj,jk) = 0.0_wp
6284
6285	END SELECT
6286
6287	END SELECT
6288
6289	! End of slab
6290	! ===========
6291
6292	END DO
6293	#endif
6294
6295	!! Scatter back to pt3d
6296	DO jr = 1, ndim_rank_north
6297	jproc=nrank_north(jr)+1
6298	ildi=nldit (jproc)
6299	ilei=nleit (jproc)
6300	iilb=pielb(jproc)
6301	!ARPDBG - make loops explicit for performance?
6302	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = &
6303	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk)
6304	END DO
6305
6306	ENDIF ! only done on proc 0 of ncomm_north
6307
6308	CALL prof_region_end(NORTH3DAPPSYMM, iprofStat)
6309
6310	!ARPDBG - could do above on every 'northern' pe and then don't have to
6311	! do scatter below...
6312
6313	CALL prof_region_begin(NORTH3DSCATTER, "North3DScatter", iprofStat)
6314
6315	#ifdef key_mpp_shmem
6316	not done yet in shmem : compiler error
6317	#elif key_mpp_mpi
6318	IF ( npolj /= 0 ) THEN
6319	itaille=nwidthmaxjpkorigijpj
6320	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
6321	znorthloc, itaille,MPI_DOUBLE_PRECISION, &
6322	0,ncomm_north,ierr)
6323	ENDIF
6324	#endif
6325
6326	! put in the last ijpj jlines of pt3d znorthloc while allowing
6327	! for any trimming of domain (see earlier comments and diagram in
6328	! mpp_lbc_north_2d).
6329	#if defined key_z_first
6330	DO ij = jpjglo - jeub + 1, ijpj, 1
6331	jj = nlcj - ijpj + ij
6332	DO jk = 1 , jpk
6333	#else
6334	DO jk = 1 , jpk
6335	DO ij = jpjglo - jeub + 1, ijpj, 1
6336	jj = nlcj - ijpj + ij
6337	#endif
6338	pt3d(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij,jk)
6339	END DO
6340	END DO
6341
6342	CALL prof_region_end(NORTH3DSCATTER, iprofStat)
6343
6344	#endif /* key_mpp_mpi */
6345
6346	END SUBROUTINE mpp_lbc_north_3d
6347
6348	!===================================================================
6349
6350	SUBROUTINE mpp_lbc_north_i3d ( ib3, cd_type, isgn )
6351	!!---------------------------------------------------------------------
6352	!! * routine mpp_lbc_north_3d *
6353	!!
6354	!! ** Purpose :
6355	!! Ensure proper north fold horizontal bondary condition in mpp
6356	!! configuration in case of jpn1 > 1
6357	!!
6358	!! ** Method :
6359	!! Gather the 4 northern lines of the global domain on 1 processor
6360	!! and apply lbc north-fold on this sub array. Then scatter the
6361	!! fold array back to the processors.
6362	!!
6363	!! History :
6364	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
6365	!! from lbc routine
6366	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding
6367	!! rules of lbc_lnk
6368	!!----------------------------------------------------------------------
6369	USE par_oce, ONLY : jpni
6370	USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, &
6371	nwidthmax
6372	USE mapcomm_mod, ONLY : pielb, piesub
6373	USE lib_mpp, ONLY : ctl_stop
6374	IMPLICIT none
6375	!! * Arguments
6376	CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points
6377	! ! = T, U, V, F or W gridp'ts
6378	INTEGER, DIMENSION(:,:,:), INTENT( inout ) :: &
6379	ib3 ! 3D array on which the boundary condition is applied
6380	INTEGER, INTENT( in ) :: &
6381	isgn ! control of the sign change
6382	! ! = -1. , the sign is changed if north fold boundary
6383	! ! = 1. , the sign is kept if north fold boundary
6384
6385	!! * Local declarations
6386	INTEGER :: ijpj
6387	INTEGER :: ijpjm1
6388	INTEGER :: ii, ji, jj, jk, jr, jproc
6389	INTEGER :: ierr
6390	INTEGER :: ildi,ilei,iilb
6391	INTEGER :: ij,ijt,iju
6392	INTEGER :: itaille
6393
6394	!FTRANS ztab :I :I :z
6395	!FTRANS znorthgloio :I :I :z :
6396	!FTRANS znorthloc :I :I :z
6397	INTEGER, DIMENSION(:,:,:) , ALLOCATABLE :: ztab
6398	INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
6399	INTEGER, DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc
6400	!!----------------------------------------------------------------------
6401
6402	! If we get in this routine it s because : North fold condition and
6403	! mpp with more than one proc across i : we deal only with the North
6404	! condition
6405
6406	ijpj = num_nfold_rows
6407	ijpjm1 = ijpj - 1
6408
6409	IF(.not. ALLOCATED(ztab))THEN
6410
6411	ALLOCATE(ztab(jpiglo,ijpj,jpkorig), &
6412	znorthgloio(nwidthmax,ijpj,jpkorig,jpni), &
6413	znorthloc(nwidthmax,ijpj,jpkorig), &
6414	STAT=ierr)
6415	IF(ierr .ne. 0)THEN
6416	CALL ctl_stop('STOP','mpp_lbc_north_i3d: memory allocation failed' )
6417	END IF
6418	END IF
6419
6420	! 0. Sign setting
6421	! ---------------
6422
6423	! put in znorthloc the last ijpj jlines of pt3d while allowing
6424	! for any trimming of domain (see earlier comments and diagram in
6425	! mpp_lbc_north_2d).
6426	znorthloc(:,:,:) = 0 ! because of padding for nwidthmax and domain
6427	! trimming
6428	#if defined key_z_first
6429	DO ij = jpjglo - jeub + 1, ijpj, 1
6430	jj = nlcj - ijpj + ij
6431	DO jk = 1, jpk
6432	#else
6433	DO jk = 1, jpk
6434	DO ij = jpjglo - jeub + 1, ijpj, 1
6435	jj = nlcj - ijpj + ij
6436	#endif
6437	znorthloc(nldi:nlei,ij,jk) = ib3(nldi:nlei,jj,jk)
6438	END DO
6439	END DO
6440
6441
6442	IF (npolj /= 0 ) THEN
6443	! Build in proc 0 of ncomm_north the znorthgloio
6444	znorthgloio(:,:,:,:) = 0
6445
6446	#ifdef key_mpp_shmem
6447	not done : compiler error
6448	#elif defined key_mpp_mpi
6449	! All domains send this number of elements. Narrower domains
6450	! therefore send data padded with zeros
6451	itaille=nwidthmaxjpkijpj
6452	CALL MPI_GATHER(znorthloc, itaille,MPI_INTEGER, &
6453	znorthgloio,itaille,MPI_INTEGER, &
6454	0, ncomm_north, ierr)
6455	#endif
6456
6457	ENDIF
6458
6459	IF (narea == north_root+1 ) THEN
6460	! recover the global north array
6461	ztab(:,:,:) = 0
6462
6463	DO jr = 1, ndim_rank_north
6464	jproc = nrank_north(jr) + 1
6465	ildi = nldit (jproc)
6466	ilei = nleit (jproc)
6467	iilb = pielb(jproc)
6468	! ARPDBG explicit loops for performance?
6469	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = &
6470	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr)
6471	END DO
6472
6473
6474	#if defined key_z_first
6475	! 2. North-Fold boundary conditions
6476	! ----------------------------------
6477
6478	SELECT CASE ( npolj )
6479
6480	CASE ( 3, 4 ) ! * North fold T-point pivot
6481
6482	DO jk = 1, jpk, 1
6483	ztab( 1 ,ijpj,jk) = 0
6484	ztab(jpiglo,ijpj,jk) = 0
6485	END DO
6486
6487	SELECT CASE ( cd_type )
6488
6489	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6490	DO ji = 2, jpiglo
6491	ijt = jpiglo-ji+2
6492	DO jk = 1, jpk, 1
6493	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6494	END DO
6495	END DO
6496	DO ji = jpiglo/2+1, jpiglo
6497	ijt = jpiglo-ji+2
6498	DO jk = 1, jpk, 1
6499	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6500	END DO
6501	END DO
6502
6503	CASE ( 'U' ) ! U-point
6504	DO ji = 1, jpiglo-1
6505	iju = jpiglo-ji+1
6506	DO jk = 1, jpk, 1
6507	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk)
6508	END DO
6509	END DO
6510	DO ji = jpiglo/2, jpiglo-1
6511	iju = jpiglo-ji+1
6512	DO jk = 1, jpk, 1
6513	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6514	END DO
6515	END DO
6516
6517	CASE ( 'V' ) ! V-point
6518	DO ji = 2, jpiglo
6519	ijt = jpiglo-ji+2
6520	DO jk = 1, jpk, 1
6521	ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk)
6522	ztab(ji,ijpj ,jk) = isgn * ztab(ijt,ijpj-3,jk)
6523	END DO
6524	END DO
6525
6526	CASE ( 'F' , 'G' ) ! F-point
6527	DO ji = 1, jpiglo-1
6528	iju = jpiglo-ji+1
6529	DO jk = 1, jpk, 1
6530	ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk)
6531	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-3,jk)
6532	END DO
6533	END DO
6534
6535	END SELECT
6536
6537	CASE ( 5, 6 ) ! * North fold F-point pivot
6538
6539	DO jk = 1, jpk, 1
6540	ztab( 1 ,ijpj,jk) = 0
6541	ztab(jpiglo,ijpj,jk) = 0
6542	END DO
6543
6544	SELECT CASE ( cd_type )
6545
6546	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6547	DO ji = 1, jpiglo
6548	ijt = jpiglo-ji+1
6549	DO jk = 1, jpk, 1
6550	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk)
6551	END DO
6552	END DO
6553
6554	CASE ( 'U' ) ! U-point
6555	DO ji = 1, jpiglo-1
6556	iju = jpiglo-ji
6557	DO jk = 1, jpk, 1
6558	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk)
6559	END DO
6560	END DO
6561
6562	CASE ( 'V' ) ! V-point
6563	DO ji = 1, jpiglo
6564	ijt = jpiglo-ji+1
6565	DO jk = 1, jpk, 1
6566	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6567	END DO
6568	END DO
6569	DO ji = jpiglo/2+1, jpiglo
6570	ijt = jpiglo-ji+1
6571	DO jk = 1, jpk, 1
6572	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6573	END DO
6574	END DO
6575
6576	CASE ( 'F' , 'G' ) ! F-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-2,jk)
6581	END DO
6582	END DO
6583	DO ji = jpiglo/2+1, jpiglo-1
6584	iju = jpiglo-ji
6585	DO jk = 1, jpk, 1
6586	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6587	END DO
6588	END DO
6589
6590	END SELECT
6591
6592	CASE DEFAULT ! * closed
6593
6594	SELECT CASE ( cd_type)
6595
6596	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6597	DO ji = 1, jpiglo, 1
6598	DO jk = 1, jpk, 1
6599	ztab(ji, 1 ,jk) = 0
6600	ztab(ji,ijpj,jk) = 0
6601	END DO
6602	END DO
6603
6604	CASE ( 'F' ) ! F-point
6605	DO ji = 1, jpiglo, 1
6606	DO jk = 1, jpk, 1
6607	ztab(ji,ijpj,jk) = 0
6608	END DO
6609	END DO
6610
6611	END SELECT
6612
6613	END SELECT
6614
6615	! End of slab
6616	! ===========
6617	#else
6618	! Horizontal slab
6619	! ===============
6620
6621	DO jk = 1, jpk
6622
6623
6624	! 2. North-Fold boundary conditions
6625	! ----------------------------------
6626
6627	SELECT CASE ( npolj )
6628
6629	CASE ( 3, 4 ) ! * North fold T-point pivot
6630
6631	ztab( 1 ,ijpj,jk) = 0
6632	ztab(jpiglo,ijpj,jk) = 0
6633
6634	SELECT CASE ( cd_type )
6635
6636	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6637	DO ji = 2, jpiglo
6638	ijt = jpiglo-ji+2
6639	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6640	END DO
6641	DO ji = jpiglo/2+1, jpiglo
6642	ijt = jpiglo-ji+2
6643	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6644	END DO
6645
6646	CASE ( 'U' ) ! U-point
6647	DO ji = 1, jpiglo-1
6648	iju = jpiglo-ji+1
6649	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk)
6650	END DO
6651	DO ji = jpiglo/2, jpiglo-1
6652	iju = jpiglo-ji+1
6653	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6654	END DO
6655
6656	CASE ( 'V' ) ! V-point
6657	DO ji = 2, jpiglo
6658	ijt = jpiglo-ji+2
6659	ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk)
6660	ztab(ji,ijpj ,jk) = isgn * ztab(ijt,ijpj-3,jk)
6661	END DO
6662
6663	CASE ( 'F' , 'G' ) ! F-point
6664	DO ji = 1, jpiglo-1
6665	iju = jpiglo-ji+1
6666	ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk)
6667	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-3,jk)
6668	END DO
6669
6670	END SELECT
6671
6672	CASE ( 5, 6 ) ! * North fold F-point pivot
6673
6674	ztab( 1 ,ijpj,jk) = 0
6675	ztab(jpiglo,ijpj,jk) = 0
6676
6677	SELECT CASE ( cd_type )
6678
6679	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6680	DO ji = 1, jpiglo
6681	ijt = jpiglo-ji+1
6682	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk)
6683	END DO
6684
6685	CASE ( 'U' ) ! U-point
6686	DO ji = 1, jpiglo-1
6687	iju = jpiglo-ji
6688	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk)
6689	END DO
6690
6691	CASE ( 'V' ) ! V-point
6692	DO ji = 1, jpiglo
6693	ijt = jpiglo-ji+1
6694	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6695	END DO
6696	DO ji = jpiglo/2+1, jpiglo
6697	ijt = jpiglo-ji+1
6698	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6699	END DO
6700
6701	CASE ( 'F' , 'G' ) ! F-point
6702	DO ji = 1, jpiglo-1
6703	iju = jpiglo-ji
6704	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-2,jk)
6705	END DO
6706	DO ji = jpiglo/2+1, jpiglo-1
6707	iju = jpiglo-ji
6708	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6709	END DO
6710
6711	END SELECT
6712
6713	CASE DEFAULT ! * closed
6714
6715	SELECT CASE ( cd_type)
6716
6717	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6718	ztab(:, 1 ,jk) = 0
6719	ztab(:,ijpj,jk) = 0
6720
6721	CASE ( 'F' ) ! F-point
6722	ztab(:,ijpj,jk) = 0
6723
6724	END SELECT
6725
6726	END SELECT
6727
6728	! End of slab
6729	! ===========
6730
6731	END DO
6732	#endif
6733
6734	!! Scatter back to pt3d
6735	DO jr = 1, ndim_rank_north
6736	jproc=nrank_north(jr)+1
6737	ildi=nldit (jproc)
6738	ilei=nleit (jproc)
6739	iilb=pielb(jproc)
6740	! DO jk= 1, jpk
6741	! DO jj=1,ijpj
6742	! DO ji=ildi,ilei
6743	! znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk)
6744	! END DO
6745	! END DO
6746	! END DO
6747	! ARPDBG - what about halos?
6748	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = &
6749	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk)
6750	END DO
6751
6752	ENDIF ! only done on proc 0 of ncomm_north
6753
6754	#ifdef key_mpp_shmem
6755	not done yet in shmem : compiler error
6756	#elif key_mpp_mpi
6757	IF ( npolj /= 0 ) THEN
6758	itaille=nwidthmaxjpkijpj
6759	CALL MPI_SCATTER(znorthgloio,itaille,MPI_INTEGER, &
6760	znorthloc, itaille,MPI_INTEGER, &
6761	0, ncomm_north, ierr)
6762	ENDIF
6763	#endif
6764
6765	! put in the last ijpj jlines of pt3d znorthloc while allowing
6766	! for any trimming of domain (see earlier comments and diagram in
6767	! mpp_lbc_north_2d).
6768	#if defined key_z_first
6769	DO ij = jpjglo - jeub + 1, ijpj, 1
6770	jj = nlcj - ijpj + ij
6771	DO ii = nldi, nlei, 1
6772	DO jk = 1 , jpk
6773	#else
6774	DO jk = 1 , jpk
6775	DO ij = jpjglo - jeub + 1, ijpj, 1
6776	jj = nlcj - ijpj + ij
6777	DO ii = nldi, nlei, 1
6778	#endif
6779	ib3(ii,jj,jk)= znorthloc(ii,ij,jk)
6780	END DO
6781	END DO
6782	END DO
6783
6784	END SUBROUTINE mpp_lbc_north_i3d
6785
6786	!====================================================================
6787
6788	END MODULE exchmod
6789
6790	! Copy n contiguous real*8 elements from a to b.
6791	! We expect the compiler to optimise this into a call
6792	! to the system memory copy routine.
6793
6794	SUBROUTINE do_real8_copy( n, a, b )
6795	IMPLICIT none
6796
6797	! arguments
6798	INTEGER, INTENT(in) :: n
6799	REAL*8, dimension(n), INTENT(in ) :: a
6800	REAL*8, DIMENSION(n), INTENT(out) :: b
6801
6802	! local variables
6803	integer :: i
6804
6805	do i=1,n
6806	b(i) = a(i)
6807	end do
6808
6809	END SUBROUTINE do_real8_copy

Note: See TracBrowser for help on using the repository browser.

Download in other formats: