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 @ 4466

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

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

Download in other formats: