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

Last change on this file since 4409 was 4409, checked in by trackstand2, 10 years ago
Changes to allow jpk to be modified to deepest level within a subdomain. jpkorig holds original value.
File size: 230.6 KB

Line
1	MODULE exchmod
2	USE par_oce, ONLY: wp, jpiglo, jpjglo, jpkdta, jpi, jpj, jpk, jpkorig
3	#if defined key_mpp_mpi
4	USE mpi ! For better interface checking
5	#endif
6	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
7	USE dom_oce, ONLY: narea
8	#endif
9	USE profile
10	! USE timing, ONLY: timing_start, timing_stop
11	! Make some key parameters from mapcomm_mod available to all who
12	! USE this module
13	USE mapcomm_mod, ONLY: Iminus, Iplus, Jminus, Jplus, NONE, &
14	jeub
15	IMPLICIT none
16
17	!!#define DEBUG_COMMS
18
19	PRIVATE
20
21	! Module containing variables to support the automatic allocation
22	! of tags and flags for the exchange and collective communications
23	! routines.
24
25	! indexs, indexr- Array indexes for send and receive flags.
26	! max_flags - The number of slots in the flag arrays
27	! i.e. the maximum number of simultaneous communications
28	! current_tag - The current (last assigned) tag value
29	! This is shared between exchanges and global operations
30	! to avoid conflicts by the use of the same tag value.
31	! min_tag - The minimum or starting tag value.
32	! max_tag - The maximum tag value. When tags reach this value
33	! they start again from the minimum.
34	! max_tag_used - Records the largest tag value actually used.
35	! n_tag_cycles - Number of cycles round the range min_tag to max_tag.
36	! first_mod - First time flag for use of this module.
37
38	! Set of arrays for exchange operations.
39
40	! exch_flags - Array of flag arrays for exchanges
41	! exch_flags1d - Array of only the current MPI receive operations
42	! exch_tag - The tag value associated with this exchange
43	! exch_busy - Indicates whether a slot in the flag array is being used
44
45	INTEGER, PARAMETER :: indexs=1,indexr=2
46	INTEGER, PARAMETER :: max_flags=40
47	INTEGER, PARAMETER :: min_tag=0
48	INTEGER :: current_tag,max_tag_used,max_tag,n_tag_cycles=0
49	LOGICAL :: first_mod=.TRUE.
50
51	INTEGER, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: exch_flags
52	INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: exch_tag, exch_flags1d
53	LOGICAL, ALLOCATABLE, DIMENSION(:), SAVE :: exch_busy
54
55	! variables used in case of north fold condition in mpp_mpi
56	! with jpni > 1
57	INTEGER, SAVE :: & !
58	ngrp_world, & ! group ID for the world processors
59	ngrp_north, & ! group ID for the northern processors (to be fold)
60	ncomm_north, & ! communicator made by the processors belonging to ngrp_north
61	ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)
62
63	INTEGER, SAVE :: north_root ! number (in the comm_opa) of proc 0 in the northern comm
64	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north ! dim. ndim_rank_north, number
65	! of the procs belonging to ncomm_north
66	LOGICAL, SAVE :: do_nfold ! Whether this PE contributes to N-fold exchange
67	! - takes domain trimming into account.
68	INTEGER, PARAMETER :: num_nfold_rows = 4 ! No. of rows at the top of the
69	! global domain to use in applying
70	! the north-fold condition (no value
71	! other than 4 currently tested)
72
73	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nfold_npts ! How many points each
74	! northern proc contrib
75	! to nfold exchange
76
77	!FTRANS r3dptr :I :I :z
78	!FTRANS i3dptr :I :I :z
79	TYPE exch_item
80	INTEGER :: halo_width
81	INTEGER, DIMENSION(4) :: dirn
82	INTEGER :: isgn
83	CHARACTER(LEN=1) :: grid
84	LOGICAL :: lfill
85	INTEGER, DIMENSION(:,:), POINTER :: i2dptr
86	INTEGER, DIMENSION(:,:,:), POINTER :: i3dptr
87	REAL(wp), DIMENSION(:,:), POINTER :: r2dptr
88	REAL(wp), DIMENSION(:,:,:), POINTER :: r3dptr
89	END TYPE exch_item
90
91	TYPE (exch_item), ALLOCATABLE, SAVE :: exch_list(:)
92	INTEGER, SAVE :: nextFreeExchItem, maxExchItems
93
94	! Buffer for doing halo-exchange.
95	! For a 3D array, halos are 2D slabs but copied into these buffers
96	! as 1D vectors. 2nd dimension refers to the direction of the
97	! communication.
98	! For a 2D array, halos are 1D vectors anyway.
99	REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: sendBuff, recvBuff
100	INTEGER , DIMENSION(:,:), ALLOCATABLE, SAVE :: sendIBuff, recvIBuff
101
102	INTERFACE bound_exch
103	MODULE PROCEDURE bound_exch2, bound_exch2i, &
104	bound_exch3, bound_exch3i
105	END INTERFACE bound_exch
106
107	INTERFACE apply_north_fold
108	MODULE PROCEDURE apply_north_fold2, apply_north_fold2i, &
109	apply_north_fold3, apply_north_fold3i
110	END INTERFACE apply_north_fold
111
112	INTERFACE mpp_lbc_north
113	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_i3d, &
114	mpp_lbc_north_2d, mpp_lbc_north_i2d
115	END INTERFACE
116
117	PUBLIC get_exch_handle, free_exch_handle, bound_exch, &
118	exch_tag, exch_flags, indexs, indexr, &
119	nrank_north, north_root, ndim_rank_north, &
120	ngrp_north, ngrp_world, ncomm_north, &
121	num_nfold_rows, do_nfold, nfold_npts, &
122	exchmod_alloc, add_exch, bound_exch_list, &
123	Iminus, Iplus, Jminus, Jplus, NONE, &
124	lbc_exch3, lbc_exch2
125
126	#if defined key_mpp_mpi
127	PUBLIC MPI_COMM_WORLD, MPI_Wtime
128	#endif
129
130	! MPI only
131	!!$#if defined key_mpp_mpi
132	!!$ INCLUDE "mpif.h"
133	!!$#endif
134	!!$#if defined ARPVAMPIR
135	!!$# include "vampir_sym_defs.inc"
136	!!$#endif
137
138	CONTAINS
139
140	INTEGER FUNCTION exchmod_alloc()
141	USE mapcomm_mod, Only: MaxComm
142	IMPLICIT none
143	! Locals
144	INTEGER :: ierr, ii
145	! Since halos are broken up into wet-point-only patches we
146	! allocate the send and receive buffers on a per-PE basis once we
147	! know the sizes of the patches (in exchs_generic).
148	maxExchItems = 20
149	ALLOCATE(exch_list(maxExchItems), &
150	exch_flags(max_flags,MaxComm,2), &
151	exch_flags1d(MaxComm), &
152	exch_busy(max_flags), &
153	exch_tag(max_flags), &
154	STAT=ierr)
155
156	IF(ierr .eq. 0)THEN
157
158	DO ii=1,maxExchItems,1
159	NULLIFY(exch_list(ii)%r2dptr, exch_list(ii)%r3dptr, &
160	exch_list(ii)%i2dptr, exch_list(ii)%i3dptr)
161	END DO
162
163	exch_busy = .FALSE.
164	ELSE
165	maxExchItems = 0
166	END IF
167
168	nextFreeExchItem = 1
169
170	! Pass back the allocation status flag
171	exchmod_alloc = ierr
172
173	END FUNCTION exchmod_alloc
174
175
176	INTEGER FUNCTION get_exch_handle ( )
177	! ---------------------------------------------------------------
178	! Gets a new exchange handle
179	! ---------------------------------------------------------------
180	!!$#if defined DEBUG \|\| defined DEBUG_COMMS
181	!!$ USE in_out_manager, ONLY: numout, lwp
182	!!$ USE dom_oce, ONLY: narea
183	!!$#endif
184	USE mapcomm_mod, ONLY: MaxCommDir
185	IMPLICIT NONE
186
187	! Local variables.
188
189	INTEGER :: h,ierr
190	LOGICAL :: got
191
192	IF ( first_mod ) THEN
193
194	! First time in the module (i.e. exch or glob) set up the tags.
195
196	! Set the maximum tag value.
197
198	got = .FALSE.
199	#if defined key_mpp_mpi
200	CALL MPI_attr_get(MPI_comm_world,MPI_tag_ub,max_tag,got,ierr)
201	IF ( ierr.NE.0 ) CALL abort ()
202	#endif /* key_mpp_mpi */
203	IF ( .NOT.got ) THEN
204
205	! If no value was returned use the minimum possible tag max.
206	! (p. 28 of Version 2.1 of the MPI standard or p. 19 of V.1 of the standard.)
207	max_tag = 32767
208	ENDIF
209	#ifdef DEBUG
210	IF ( lwp ) WRITE (numout,*) 'MAX_TAG: set to ',max_tag
211	#endif
212
213	! Set the current tag to the minimum.
214
215	current_tag = min_tag
216	max_tag_used = current_tag
217
218	first_mod = .FALSE.
219	ENDIF
220
221	! Look for a free location in the flags array.
222
223	flag_search : DO h=1,max_flags
224	IF ( .NOT.exch_busy(h) ) EXIT flag_search
225	ENDDO flag_search
226
227	IF ( h.GT.max_flags ) THEN
228
229	! If no free flags array was found, flag an error.
230
231	STOP 'ERROR: get_exch_handle: no free flag array'
232	ELSE
233
234	! Assign a new tag.
235
236	exch_busy(h) = .TRUE.
237
238	IF ( current_tag.GE.(max_tag-MaxCommDir) ) THEN
239
240	! Wrap around.
241
242	current_tag = min_tag
243	n_tag_cycles = n_tag_cycles+1
244	ELSE
245	current_tag = current_tag + MaxCommDir
246	ENDIF
247	max_tag_used = MAX(max_tag_used,current_tag)
248	exch_tag(h) = current_tag
249
250	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
251	!!$ IF ( lwp ) THEN
252	!!$ WRITE (numout,'(1x,a,i6,a,i8,a,i3,a,i3,a)') &
253	!!$ 'Process ',narea-1,' exch tag ',exch_tag(h) &
254	!!$ ,' assigned flags ',h,' (',COUNT(exch_busy),' busy)'
255	!!$ CALL flush (numout)
256	!!$ ENDIF
257	!!$#endif
258	ENDIF
259
260	get_exch_handle = h
261
262	RETURN
263
264	END FUNCTION get_exch_handle
265
266	! ---------------------------------------------------------------
267
268	SUBROUTINE free_exch_handle ( h )
269	! Frees exchange handle, h.
270	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
271	!!$ USE in_out_manager, ONLY: numout, lwp
272	!!$ USE dom_oce, ONLY: narea
273	!!$#endif
274	IMPLICIT NONE
275
276	! Subroutine arguments.
277	INTEGER :: h ! Handle to be free'd
278
279	! Free the flags array.
280
281	IF ( h.GT.0 .AND. h.LE.max_flags ) THEN
282	exch_busy(h) = .FALSE.
283	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
284	!!$ IF ( lwp ) THEN
285	!!$ WRITE (numout,'(1x,a,i6,a,i8,a,i3)') 'Process ',narea-1,' exch tag ',exch_tag(h) ,' freed flags ',h
286	!!$ CALL flush (numout)
287	!!$ ENDIF
288	!!$#endif
289	ELSE
290	WRITE (,) 'free_exch_handle: invalid handle ',h
291	ENDIF
292
293	END SUBROUTINE free_exch_handle
294
295	! ------------------------------------------------------------------------
296
297	SUBROUTINE bound_exch_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
298	comm1, comm2, comm3, comm4, &
299	cd_type, lfill, pval, isgn, lzero )
300	USE par_oce, ONLY: wp, jpreci, jprecj, jpim1
301	USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, &
302	nperio, nbondi, npolj, narea, jpkf
303	USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc
304	USE mapcomm_mod, ONLY: trimmed, eidx, widx
305	IMPLICIT none
306	INTEGER, INTENT(in) :: nhalo,nhexch
307	!FTRANS b3 :I :I :z
308	!FTRANS ib3 :I :I :z
309	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:) :: b2
310	INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:) :: ib2
311	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: b3
312	INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: ib3
313	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
314	CHARACTER(len=1), INTENT(in) :: cd_type
315	LOGICAL, OPTIONAL, INTENT(in) :: lfill
316	REAL(wp),OPTIONAL, INTENT(in) :: pval ! background value (used at closed boundaries)
317	INTEGER, OPTIONAL, INTENT(in) :: isgn
318	LOGICAL, OPTIONAL, INTENT(in) :: lzero ! Whether to set halo values on closed boundaries
319	! Local arguments
320	INTEGER :: itag ! Communication handle
321	INTEGER :: isgnarg
322	INTEGER :: ii, jj, jk, ji ! Loop indices
323	INTEGER :: ileft, iright ! First and last x-coord of internal points
324	INTEGER :: kdim1
325	INTEGER :: iland ! Land values - zero by default unless pval passed in.
326	REAL(wp) :: zland ! " "
327	LOGICAL :: lfillarg, lzeroarg
328	!!--------------------------------------------------------------------
329
330	#if ! defined key_mpp_rkpart
331	RETURN
332	#endif
333
334	! CALL prof_region_begin(ARPCOMMS, "IndivComms", iprofStat)
335	! CALL timing_start('bound_exch_generic')
336
337	! Deal with optional routine arguments
338	lzeroarg = .TRUE.
339	lfillarg = .FALSE.
340	isgnarg = 1
341	zland = 0.0_wp
342
343	IF( PRESENT(lfill) ) lfillarg = lfill
344	IF( PRESENT(isgn) ) isgnarg = isgn
345	IF( PRESENT(lzero) ) lzeroarg = lzero
346	IF( PRESENT(pval) ) zland = pval
347	iland=INT(zland)
348
349	! Find out the size of 3rd dimension of the array
350
351	kdim1 = 1
352	IF ( PRESENT(b3) ) THEN
353	#if defined key_z_first
354	kdim1 = SIZE(b3,dim=1)
355	#else
356	kdim1 = SIZE(b3,dim=3)
357	#endif
358	! If we've been passed a 'standard' 3D array then
359	! we can limit the length of our z loops to the
360	! no. of levels above the ocean floor.
361	IF(kdim1 == jpkorig)kdim1 = jpkf
362	ELSEIF ( PRESENT(ib3) ) THEN
363	#if defined key_z_first
364	kdim1 = SIZE(ib3,dim=1)
365	#else
366	kdim1 = SIZE(ib3,dim=3)
367	#endif
368	! If we've been passed a 'standard' 3D array then
369	! we can limit the length of our z loops to the
370	! no. of levels above the ocean floor.
371	IF(kdim1 == jpk)kdim1 = jpkf
372	ELSEIF ( PRESENT(b2) ) THEN
373	kdim1 = SIZE(b2,dim=2)
374	ELSEIF ( PRESENT(ib2) ) THEN
375	kdim1 = SIZE(ib2,dim=2)
376	ENDIF
377
378	IF( lfillarg ) THEN
379
380	! (nldi,nlej) is only a valid TL corner point if we're not on
381	! an external boundary. If we are then we need nldi+1 if we
382	! have cyclic E-W boundary conditions.
383	ileft = nldi
384	IF( (ilbext .AND. (.NOT. trimmed(widx,narea))) .AND. cyclic_bc) &
385	ileft = ileft + 1
386
387	iright = nlei
388	IF( (iubext .AND. (.NOT. trimmed(eidx,narea))) .AND. cyclic_bc) &
389	iright = iright - 1
390
391	IF ( PRESENT(b2) ) THEN
392	DO jj = 1, jprecj, 1 ! only fill extra allows last line
393	b2(nldi:nlei , jj) = b2(nldi:nlei, nldj)
394	b2(1:jpreci , jj) = b2(ileft, nldj) ! Bottom-left corner points
395	b2(nlci:jpi, jj) = b2(iright, nldj) ! Bottom-right corner points
396	END DO
397
398	DO jj = nlej+1, jpj, 1 ! only fill extra allows last line
399	b2(nldi:nlei , jj) = b2(nldi:nlei, nlej)
400	b2(1:jpreci , jj) = b2(ileft, nlej) ! Top-left corner points
401	b2(nlci:jpi, jj) = b2(iright, nlej)! Top-right corner points
402	END DO
403
404	DO jj = nldj,nlej,1 ! Left halo columns
405	b2(1: jpreci , jj ) = b2(ileft, jj )
406	END DO
407
408	DO jj = nldj, nlej, 1 ! Right halo columns
409	b2(nlci:jpi , jj ) = b2(iright, jj )
410	END DO
411
412	ELSE IF ( PRESENT(ib2) ) THEN
413
414	DO jj = 1, jprecj ! only fill extra allows last line
415	ib2(nldi:nlei , jj) = ib2(nldi:nlei, nldj)
416	ib2( 1:jpreci, jj) = ib2(ileft , nldj) ! Bottom-left corner points
417	ib2(nlci:jpi , jj) = ib2(iright , nldj) ! Bottom-right corner points
418	END DO
419
420	DO jj = nlej+1, jpj
421	ib2(nldi:nlei, jj) = ib2(nldi:nlei, nlej)
422	ib2(1:jpreci , jj) = ib2(ileft , nlej) ! Top-left corner points
423	ib2(nlci:jpi , jj) = ib2(iright , nlej) ! Top-right corner points
424	END DO
425
426	DO jj = nldj,nlej,1 ! West-most columns
427	ib2(1:jpreci, jj) = ib2(ileft, jj)
428	END DO
429
430	DO jj = nldj, nlej, 1 ! East-most columns
431	ib2(nlci:jpi, jj) = ib2(iright, jj)
432	END DO
433
434	ELSE IF ( PRESENT(b3) ) THEN
435
436	#if defined key_z_first
437	DO jj = 1, jprecj, 1 ! Bottom rows
438	DO ii = nldi, nlei, 1
439	b3(ii, jj, 1:kdim1) = b3(ii, nldj, 1:kdim1) ! Bottom rows
440	END DO
441	DO ii = 1, jpreci, 1
442	b3(ii, jj, 1:kdim1) = b3(ileft ,nldj,1:kdim1) ! Bottom-L corner
443	END DO
444	DO ii = nlci, jpi, 1
445	b3(ii, jj, 1:kdim1) = b3(iright ,nldj,1:kdim1) ! Bottom-R corner
446	END DO
447	END DO
448
449	DO jj = nlej+1, jpj, 1 ! Top rows
450	DO ii = 1, jpreci, 1
451	b3(ii, jj,1:kdim1) = b3(ileft,nlej,1:kdim1) ! Top-L corner pts
452	END DO
453	DO ii = nldi, nlei, 1
454	b3(ii, jj,1:kdim1) = b3(ii,nlej,1:kdim1) ! Top rows
455	END DO
456	DO ii = nlci, jpi, 1
457	b3(ii , jj,1:kdim1) = b3(iright,nlej,1:kdim1) ! Top-R corner pts
458	END DO
459	END DO
460
461	DO jj = nldj, nlej, 1 ! E-most columns
462	DO ii = nlci, jpi, 1
463	b3(ii, jj, 1:kdim1) = b3(iright, jj, 1:kdim1)
464	END DO
465	END DO
466
467	DO jj = nldj, nlej, 1 ! W-most columns
468	DO ii = 1, jpreci, 1
469	b3(ii, jj, 1:kdim1) = b3(ileft, jj, 1:kdim1)
470	END DO
471	END DO
472	#else
473	jk_loop: DO jk = 1,kdim1,1
474
475	DO jj = 1, jprecj, 1 ! Bottom rows
476	b3(nldi:nlei, jj, jk) = b3(nldi:nlei,nldj,jk) ! Bottom rows
477	b3(1:jpreci , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner
478	b3(nlci:jpi , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner
479	END DO
480
481	DO jj = nlej+1, jpj, 1 ! Top rows
482	b3(nldi:nlei, jj,jk) = b3(nldi:nlei,nlej,jk) ! Top rows
483	b3(1:jpreci , jj,jk) = b3(ileft ,nlej,jk) ! Top-L corner pts
484	b3(nlci:jpi , jj,jk) = b3(iright ,nlej,jk) ! Top-R corner pts
485	END DO
486
487	DO jj = nldj, nlej, 1 ! E-most columns
488	b3(nlci:jpi, jj, jk) = b3(iright, jj, jk)
489	END DO
490
491	DO jj = nldj, nlej, 1 ! W-most columns
492	b3(1:jpreci, jj, jk) = b3(ileft, jj, jk)
493	END DO
494
495	END DO jk_loop
496	#endif
497
498	ELSE IF ( PRESENT(ib3) ) THEN
499
500	#if defined key_z_first
501	! ARPDBG - do I need to make ii loops explicit and appropriately ordered?
502	DO jj = 1,jprecj ! Bottom rows
503	DO jk = 1,kdim1,1
504	ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
505	ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner
506	ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner
507	END DO
508	END DO
509
510	DO jj = nlej+1, jpj ! Top rows
511	DO jk = 1,kdim1,1
512	ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
513	ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts
514	ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts
515	END DO
516	END DO
517
518	DO jj = nldj,nlej, 1 ! E-most columns
519	DO jk = 1,kdim1,1
520	ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
521	END DO
522	END DO
523
524	DO jj = nldj,nlej,1 ! W-most columns
525	DO jk = 1,kdim1,1
526	ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
527	END DO
528	END DO
529	#else
530	DO jk = 1,kdim1,1
531
532	DO jj = 1,jprecj ! Bottom rows
533	ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
534	ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner
535	ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner
536	END DO
537
538	DO jj = nlej+1, jpj ! Top rows
539	ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
540	ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts
541	ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts
542	END DO
543
544	DO jj = nldj,nlej, 1 ! E-most columns
545	ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
546	END DO
547
548	DO jj = nldj,nlej,1 ! W-most columns
549	ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
550	END DO
551
552	END DO
553	#endif
554
555	END IF
556
557	ELSE ! lfillarg is .FALSE. - standard closed or cyclic treatment
558
559	! ! East-West boundaries
560	! ! ====================
561	! nbondi == 2 when a single sub-domain spans the whole width
562	! of the global domain
563	IF( nbondi == 2 .AND. & ! Cyclic east-west
564	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
565
566	IF ( PRESENT(b2) ) THEN
567
568	b2( 1 ,:) = b2(jpim1,:) ! Set west halo to last valid east value
569	b2(jpi,:) = b2(nldi ,:) ! east halo to first valid west value
570	ELSE IF ( PRESENT(ib2) ) THEN
571
572	ib2( 1 ,:) = ib2(jpim1,:)
573	ib2(jpi,:) = ib2(nldi ,:)
574	ELSE IF ( PRESENT(b3) ) THEN
575
576	#if defined key_z_first
577	DO jj = 1,jpj,1
578	DO jk = 1,kdim1,1
579	b3( 1, jj, jk) = b3(jpim1, jj, jk)
580	b3(jpi,jj, jk) = b3( 2, jj, jk)
581	END DO
582	END DO
583	#else
584	b3( 1, :, 1:kdim1) = b3(jpim1, :, 1:kdim1)
585	b3(jpi,:, 1:kdim1) = b3( 2, :, 1:kdim1)
586	#endif
587	ELSE IF ( PRESENT(ib3) ) THEN
588
589	ib3( 1, :, 1:kdim1) = ib3(jpim1, :, 1:kdim1)
590	ib3(jpi,:, 1:kdim1) = ib3( 2, :, 1:kdim1)
591	END IF
592
593	ELSE ! ... closed East-West boundaries
594
595	IF( lzeroarg )THEN
596
597	IF ( PRESENT(b2) ) THEN
598	SELECT CASE ( cd_type )
599	CASE ( 'T', 'U', 'V', 'W' , 'I' )
600	b2(1:jpreci , :) = zland ! Western halo
601	b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo
602	CASE ( 'F' )
603	b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo
604	END SELECT
605	ELSE IF ( PRESENT(ib2) ) THEN
606	SELECT CASE ( cd_type )
607	CASE ( 'T', 'U', 'V', 'W' , 'I' )
608	ib2(1:jpreci , :) = iland ! Western halo
609	ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo
610	CASE ( 'F' )
611	ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo
612	END SELECT
613	ELSE IF ( PRESENT(b3) ) THEN
614	SELECT CASE ( cd_type )
615	CASE ( 'T', 'U', 'V', 'W' )
616	#if defined key_z_first
617	DO jj=1,jpj,1
618	DO ji=1,jpreci,1
619	DO jk=1,kdim1,1
620	b3(ji, jj, jk) = zland
621	END DO
622	END DO
623	DO ji=nlci-jpreci+1,jpi,1
624	DO jk=1,kdim1,1
625	b3(ji, jj, jk) = zland
626	END DO
627	END DO
628	END DO
629	#else
630	b3(1:jpreci , :, 1:kdim1) = zland
631	b3(nlci-jpreci+1:jpi, :, 1:kdim1) = zland
632	#endif
633	CASE ( 'F' )
634	#if defined key_z_first
635	DO jj=1,jpj,1
636	DO ji = nlci-jpreci+1,jpi,1
637	DO jk = 1,kdim1,1
638	b3(ji, jj, jk) = zland
639	END DO
640	END DO
641	END DO
642	#else
643	b3(nlci-jpreci+1:jpi, :, 1:kdim1) = zland
644	#endif
645	END SELECT
646	ELSE IF ( PRESENT(ib3) ) THEN
647	SELECT CASE ( cd_type )
648	CASE ( 'T', 'U', 'V', 'W' )
649	ib3(1:jpreci , :, 1:kdim1) = iland
650	ib3(nlci-jpreci+1:jpi, :, 1:kdim1) = iland
651	CASE ( 'F' )
652	ib3(nlci-jpreci+1:jpi, :, 1:kdim1) = iland
653	END SELECT
654	END IF
655
656	END IF ! lzeroarg
657
658	END IF
659
660	IF( lzeroarg )THEN
661
662	! ! North-South boundaries (always closed)
663	! ! ======================
664	IF ( PRESENT(b2) ) THEN
665	SELECT CASE ( cd_type )
666	CASE ( 'T', 'U', 'V', 'W' , 'I' )
667	!b2(:,1:nldj-1 ) = zland
668	! Below is what is done in original lib_mpp.F90
669	b2(:,1:jprecj ) = zland
670	b2(:,nlcj-jprecj+1:jpj) = zland
671	CASE ( 'F' )
672	b2(:,nlcj-jprecj+1:jpj) = zland
673	END SELECT
674	ELSE IF ( PRESENT(ib2) ) THEN
675	SELECT CASE ( cd_type )
676	CASE ( 'T', 'U', 'V', 'W' , 'I' )
677	ib2(:,1:jprecj ) = iland
678	ib2(:,nlcj-jprecj+1:jpj) = iland
679	CASE ( 'F' )
680	ib2(:,nlcj-jprecj+1:jpj) = iland
681	END SELECT
682	ELSE IF ( PRESENT(b3) ) THEN
683	SELECT CASE ( cd_type )
684	CASE ( 'T', 'U', 'V', 'W' )
685	#if defined key_z_first
686	DO jj=1,jprecj,1
687	DO ji=1,jpi,1
688	DO jk = 1,kdim1,1
689	b3(ji, jj, jk) = zland
690	END DO
691	END DO
692	END DO
693	DO jj=nlcj-jprecj+1,jpj,1
694	DO ji=1,jpi,1
695	DO jk = 1,kdim1,1
696	b3(ji, jj, jk) = zland
697	END DO
698	END DO
699	END DO
700	#else
701	b3(:, 1:jprecj , 1:kdim1) = zland
702	b3(:, nlcj-jprecj+1:jpj, 1:kdim1) = zland
703	#endif
704	CASE ( 'F' )
705	#if defined key_z_first
706	DO jj=nlcj-jprecj+1,jpj,1
707	DO ji=1,jpi,1
708	DO jk = 1,kdim1,1
709	b3(ji, jj, jk) = zland
710	END DO
711	END DO
712	END DO
713	#else
714	b3(:, nlcj-jprecj+1:jpj, 1:kdim1) = zland
715	#endif
716	END SELECT
717	ELSE IF ( PRESENT(ib3) ) THEN
718	SELECT CASE ( cd_type )
719	CASE ( 'T', 'U', 'V', 'W' )
720	ib3(:, 1:jprecj , 1:kdim1) = iland
721	ib3(:, nlcj-jprecj+1:jpj, 1:kdim1) = iland
722	CASE ( 'F' )
723	ib3(:, nlcj-jprecj+1:jpj, 1:kdim1) = iland
724	END SELECT
725	END IF
726
727	END IF ! lzeroarg
728
729	END IF ! lfillarg
730
731	! Do East-West and North-South exchanges
732	CALL exchs_generic ( b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, &
733	nhexch=nhexch, handle=itag, &
734	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
735	cd_type=cd_type, lfill=lfillarg)
736
737	!CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, &
738	! nhexch=nhexch, handle=itag, &
739	! comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 )
740
741
742	! Apply north-fold condition
743	IF(.not. lfillarg)THEN
744	IF(PRESENT(b2))THEN
745	CALL apply_north_fold(b2, isgnarg, cd_type)
746	ELSE IF(PRESENT(ib2))THEN
747	CALL apply_north_fold(ib2, isgnarg, cd_type)
748	ELSE IF(PRESENT(b3))THEN
749	CALL apply_north_fold(b3, isgnarg, cd_type)
750	ELSE IF(PRESENT(ib3))THEN
751	CALL apply_north_fold(ib3, isgnarg, cd_type)
752	ELSE
753	STOP 'ARPDBG: ERROR - no matching version of apply_north_fold!'
754	END IF
755
756
757	!WRITE (,) 'ARPDBG: bound_exch_generic: npolj = ',npolj
758	! We only need to repeat the East and West halo swap if there
759	! IS a north-fold in the configuration.
760	!SELECT CASE (npolj)
761
762	!CASE ( 3, 4, 5, 6 )
763	IF(ndim_rank_north > 0)THEN
764
765	! Update East and West halos as required - no data sent north
766	! as it's only the northern-most PEs that have been affected
767	! by the north-fold condition.
768	! ARPDBG - inefficient since all PEs do halo swap and only
769	! those affected by the north fold actually need to - can
770	! this be done within apply_north_fold?
771	CALL exchs_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, &
772	nhexch=nhexch, handle=itag, &
773	comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
774	cd_type=cd_type, lfill=lfillarg)
775
776	END IF ! ndim_rank_north > 0
777	!END SELECT ! npolj
778
779	END IF
780
781	! CALL prof_region_end(ARPCOMMS, iprofStat)
782	! CALL timing_stop('bound_exch_generic','section')
783
784	END SUBROUTINE bound_exch_generic
785
786	! ------------------------------------------------------------------------
787
788	SUBROUTINE bound_exch_list ()
789	USE par_oce, ONLY: wp, jpreci, jprecj, jpim1
790	USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, &
791	nperio, nbondi
792	USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc
793	IMPLICIT none
794	! Local arguments
795	INTEGER :: ii, jj, jk, ifield ! Loop indices
796	INTEGER :: ileft, iright ! First and last x-coord of internal points
797	INTEGER :: kdim1
798	INTEGER :: nfields
799	!FTRANS b3 :I :I :z
800	!FTRANS ib3 :I :I :z
801	INTEGER, DIMENSION(:,:), POINTER :: ib2
802	INTEGER, DIMENSION(:,:,:), POINTER :: ib3
803	REAL, DIMENSION(:,:), POINTER :: b2
804	REAL, DIMENSION(:,:,:), POINTER :: b3
805	!!----------------------------------------------------------------------
806
807	#if ! defined key_mpp_rkpart
808	RETURN
809	#endif
810
811	NULLIFY(ib2, ib3, b2, b3)
812
813	nfields = nextFreeExchItem - 1
814
815	CALL prof_region_begin(ARPLISTCOMMS, "ListComms", iprofStat)
816
817	DO ifield=1, nfields, 1
818
819	! Find out the size of 3rd dimension of the array
820
821	kdim1 = 1
822	IF ( ASSOCIATED(exch_list(ifield)%r3dptr) ) THEN
823	b3 => exch_list(ifield)%r3dptr
824	#if defined key_z_first
825	kdim1 = SIZE(b3,dim=1)
826	#else
827	kdim1 = SIZE(b3,dim=3)
828	#endif
829	ELSEIF ( ASSOCIATED(exch_list(ifield)%i3dptr) ) THEN
830	ib3 => exch_list(ifield)%i3dptr
831	#if defined key_z_first
832	kdim1 = SIZE(ib3,dim=1)
833	#else
834	kdim1 = SIZE(ib3,dim=3)
835	#endif
836	ELSEIF ( ASSOCIATED(exch_list(ifield)%r2dptr) ) THEN
837	b2 => exch_list(ifield)%r2dptr
838	kdim1 = SIZE(b2,dim=2)
839	ELSEIF ( ASSOCIATED(exch_list(ifield)%i2dptr) ) THEN
840	ib2 => exch_list(ifield)%i2dptr
841	kdim1 = SIZE(ib2,dim=2)
842	ENDIF
843
844	IF( exch_list(ifield)%lfill ) THEN
845
846	! (nldi,nlej) is only a valid TL corner point if we're not on an
847	! external boundary. If we are AND we have cyclic E-W boundary
848	! conditions then we need nldi+1.
849	ileft = nldi
850	IF(ilbext .AND. cyclic_bc)ileft = ileft + 1
851
852	iright = nlei
853	IF(iubext .AND. cyclic_bc)iright = iright - 1
854
855	IF ( ASSOCIATED(b2) ) THEN
856
857	DO jj = 1, jprecj, 1 ! only fill extra allows last line
858	b2(nldi:nlei , jj) = b2(nldi:nlei, nldj)
859	b2(1:jpreci , jj) = b2(ileft, nldj) ! Bottom-left corner points
860	b2(nlci:jpi, jj) = b2(iright, nldj) ! Bottom-right corner points
861	END DO
862
863	DO jj = nlej+1, jpj, 1 ! only fill extra allows last line
864	b2(nldi:nlei , jj) = b2(nldi:nlei, nlej)
865	b2(1:jpreci , jj) = b2(ileft, nlej) ! Top-left corner points
866	b2(nlci:jpi, jj) = b2(iright, nlej)! Top-right corner points
867	END DO
868
869	DO jj = nldj,nlej,1 ! Left halo columns
870	b2(1: jpreci , jj ) = b2(ileft, jj )
871	END DO
872
873	DO jj = nldj, nlej, 1 ! Right halo columns
874	b2(nlci:jpi , jj ) = b2(iright, jj )
875	END DO
876
877	ELSE IF ( ASSOCIATED(ib2) ) THEN
878
879	DO jj = 1, jprecj ! only fill extra allows last line
880	ib2(nldi:nlei , jj) = ib2(nldi:nlei, nldj)
881	ib2( 1:jpreci, jj) = ib2(ileft , nldj) ! Bottom-left corner points
882	ib2(nlci:jpi , jj) = ib2(iright , nldj) ! Bottom-right corner points
883	END DO
884
885	DO jj = nlej+1, jpj
886	ib2(nldi:nlei, jj) = ib2(nldi:nlei, nlej)
887	ib2(1:jpreci , jj) = ib2(ileft , nlej) ! Top-left corner points
888	ib2(nlci:jpi , jj) = ib2(iright , nlej) ! Top-right corner points
889	END DO
890
891	DO jj = nldj,nlej,1 ! West-most columns
892	ib2(1:jpreci, jj) = ib2(ileft, jj)
893	END DO
894
895	DO jj = nldj, nlej, 1 ! East-most columns
896	ib2(nlci:jpi, jj) = ib2(iright, jj)
897	END DO
898
899	ELSE IF ( ASSOCIATED(b3) ) THEN
900
901	#if defined key_z_first
902	DO jj = 1, jprecj, 1 ! Bottom rows
903	DO ii = nldi, nlei, 1
904	DO jk = 1,kdim1,1
905	b3(ii, jj, jk) = b3(ii,nldj,jk) ! Bottom rows
906	END DO
907	END DO
908	DO ii = 1, jpreci, 1
909	DO jk = 1,kdim1,1
910	b3(ii , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner
911	END DO
912	END DO
913	DO ii = nlci, jpi, 1
914	DO jk = 1,kdim1,1
915	b3(ii , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner
916	END DO
917	END DO
918	END DO
919
920	DO jj = nlej+1, jpj, 1 ! Top rows
921	DO ii = nldi, nlei, 1
922	DO jk = 1,kdim1,1
923	b3(ii, jj,jk) = b3(ii,nlej,jk) ! Top rows
924	END DO
925	END DO
926	DO ii = 1, jpreci, 1
927	DO jk = 1,kdim1,1
928	b3(ii, jj,jk) = b3(ileft,nlej,jk) ! Top-L corner pts
929	END DO
930	END DO
931	DO ii = nlci, jpi, 1
932	DO jk = 1,kdim1,1
933	b3(ii,jj,jk) = b3(iright,nlej,jk) ! Top-R corner pts
934	END DO
935	END DO
936	END DO
937
938	DO jj = nldj, nlej, 1
939	! E-most columns
940	DO ii = nlci, jpi, 1
941	DO jk = 1,kdim1,1
942	b3(ii, jj, jk) = b3(iright, jj, jk)
943	END DO
944	END DO
945
946	! W-most columns
947	DO ii = 1, jpreci, 1
948	DO jk = 1,kdim1,1
949	b3(ii, jj, jk) = b3(ileft, jj, jk)
950	END DO
951	END DO
952	END DO
953	#else
954	jk_loop: DO jk = 1,kdim1,1
955
956	DO jj = 1, jprecj, 1 ! Bottom rows
957	b3(nldi:nlei, jj, jk) = b3(nldi:nlei,nldj,jk) ! Bottom rows
958	b3(1:jpreci , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner
959	b3(nlci:jpi , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner
960	END DO
961
962	DO jj = nlej+1, jpj, 1 ! Top rows
963	b3(nldi:nlei, jj,jk) = b3(nldi:nlei,nlej,jk) ! Top rows
964	b3(1:jpreci , jj,jk) = b3(ileft ,nlej,jk) ! Top-L corner pts
965	b3(nlci:jpi , jj,jk) = b3(iright ,nlej,jk) ! Top-R corner pts
966	END DO
967
968	DO jj = nldj, nlej, 1 ! E-most columns
969	b3(nlci:jpi, jj, jk) = b3(iright, jj, jk)
970	END DO
971
972	DO jj = nldj, nlej, 1 ! W-most columns
973	b3(1:jpreci, jj, jk) = b3(ileft, jj, jk)
974	END DO
975
976	END DO jk_loop
977	#endif
978
979	ELSE IF ( ASSOCIATED(ib3) ) THEN
980	#if defined key_z_first
981	! ARPDBG need make loops over i explicit for optimum performance
982	DO jj = 1,jprecj ! Bottom rows
983	DO jk = 1,kdim1,1
984	ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
985	ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner
986	ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner
987	END DO
988	END DO
989
990	DO jj = nlej+1, jpj ! Top rows
991	DO jk = 1,kdim1,1
992	ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
993	ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts
994	ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts
995	END DO
996	END DO
997
998	DO jj = nldj,nlej, 1 ! E-most columns
999	DO jk = 1,kdim1,1
1000	ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
1001	END DO
1002	END DO
1003
1004	DO jj = nldj,nlej,1 ! W-most columns
1005	DO jk = 1,kdim1,1
1006	ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
1007	END DO
1008	END DO
1009	#else
1010	DO jk = 1,kdim1,1
1011
1012	DO jj = 1,jprecj ! Bottom rows
1013	ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
1014	ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner
1015	ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner
1016	END DO
1017
1018	DO jj = nlej+1, jpj ! Top rows
1019	ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
1020	ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts
1021	ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts
1022	END DO
1023
1024	DO jj = nldj,nlej, 1 ! E-most columns
1025	ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
1026	END DO
1027
1028	DO jj = nldj,nlej,1 ! W-most columns
1029	ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
1030	END DO
1031
1032	END DO
1033	#endif
1034
1035	END IF
1036
1037	ELSE ! lfill is .FALSE. for this field
1038
1039	! ! East-West boundaries
1040	! ! ====================
1041	IF( nbondi == 2 .AND. & ! Cyclic east-west
1042	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1043
1044	IF ( ASSOCIATED(b2) ) THEN
1045
1046	b2( 1 ,:) = b2(jpim1,:) ! Set west halo to last valid east value
1047	b2(jpi,:) = b2(nldi ,:) ! east halo to first valid west value
1048	ELSE IF ( ASSOCIATED(ib2) ) THEN
1049
1050	ib2( 1 ,:) = ib2(jpim1,:)
1051	ib2(jpi,:) = ib2(nldi ,:)
1052	ELSE IF ( ASSOCIATED(b3) ) THEN
1053
1054	b3( 1, :, :) = b3(jpim1, :, :)
1055	b3(jpi,:, :) = b3( 2, :, :)
1056	ELSE IF ( ASSOCIATED(ib3) ) THEN
1057
1058	ib3( 1, :, :) = ib3(jpim1, :, :)
1059	ib3(jpi,:, :) = ib3( 2, :, :)
1060	END IF
1061
1062	ELSE ! ... closed
1063
1064	END IF
1065
1066	! ! North-South boundaries
1067	! ! ======================
1068	IF ( ASSOCIATED(b2) ) THEN
1069	SELECT CASE ( exch_list(ifield)%grid )
1070	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1071	b2(:,1:jprecj ) = 0.0_wp
1072	b2(:,nlcj-jprecj+1:jpj) = 0.0_wp
1073	CASE ( 'F' )
1074	b2(:,nlcj-jprecj+1:jpj) = 0.0_wp
1075	END SELECT
1076	ELSE IF ( ASSOCIATED(ib2) ) THEN
1077	SELECT CASE ( exch_list(ifield)%grid )
1078	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1079	ib2(:,1:jprecj ) = 0
1080	ib2(:,nlcj-jprecj+1:jpj) = 0
1081	CASE ( 'F' )
1082	ib2(:,nlcj-jprecj+1:jpj) = 0
1083	END SELECT
1084	ELSE IF ( ASSOCIATED(b3) ) THEN
1085	SELECT CASE ( exch_list(ifield)%grid )
1086	CASE ( 'T', 'U', 'V', 'W' )
1087	b3(:, 1:jprecj , :) = 0.0_wp
1088	b3(:, nlcj-jprecj+1:jpj, :) = 0.0_wp
1089	CASE ( 'F' )
1090	b3(:, nlcj-jprecj+1:jpj, :) = 0.0_wp
1091	END SELECT
1092	ELSE IF ( ASSOCIATED(ib3) ) THEN
1093	SELECT CASE ( exch_list(ifield)%grid )
1094	CASE ( 'T', 'U', 'V', 'W' )
1095	ib3(:, 1:jprecj , :) = 0
1096	ib3(:, nlcj-jprecj+1:jpj, :) = 0
1097	CASE ( 'F' )
1098	ib3(:, nlcj-jprecj+1:jpj, :) = 0
1099	END SELECT
1100	END IF
1101
1102	END IF ! lfillarg
1103
1104	END DO ! loop over fields
1105
1106	! Do East-West and North-South exchanges
1107	CALL exchs_generic_list ( exch_list, nfields )
1108
1109	! Apply north-fold condition to those fields that need it and delete the
1110	! others from the list
1111	CALL apply_north_fold_list(exch_list, nfields)
1112
1113	! Update East and West halos on those fields that have just had the
1114	! north-fold condition applied (will be the only ones left in the list
1115	! as the others are removed within apply_north_fold_list.)
1116	! ARPDBG - inefficient - can this be done within apply_north_fold?
1117	CALL exchs_generic_list (exch_list, nfields)
1118
1119	CALL prof_region_end(ARPLISTCOMMS, iprofStat)
1120
1121	DO ifield=1,nfields,1
1122	NULLIFY(exch_list(ifield)%r2dptr, exch_list(ifield)%r3dptr, &
1123	exch_list(ifield)%i2dptr, exch_list(ifield)%i3dptr)
1124	END DO
1125
1126	nextFreeExchItem = 1
1127
1128	END SUBROUTINE bound_exch_list
1129
1130	!=========================================================================
1131
1132	SUBROUTINE apply_north_fold_list(list, nfields)
1133	USE par_oce, ONLY: wp, jpni, jpk
1134	USE dom_oce, ONLY: npolj
1135	IMPLICIT none
1136	! Subroutine arguments.
1137	TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
1138	INTEGER, INTENT(in) :: nfields
1139	! Local variables
1140	INTEGER :: ifield
1141	INTEGER :: icount
1142
1143	icount = 0
1144
1145	DO ifield = 1, nfields, 1
1146
1147	IF(list(ifield)%lfill)THEN
1148	! This field doesn't have north-fold condition applied to it
1149	! so wipe its entry...
1150	CALL wipe_exch(list(ifield))
1151	icount = icount + 1
1152	! ...and don't do any more with it
1153	CYCLE
1154	END IF
1155
1156	END DO
1157
1158	! Check whether any of the fields need the north-fold condition
1159	! applied
1160	IF(icount .eq. nfields)RETURN
1161
1162	! Treatment without exchange (jpni odd)
1163
1164	SELECT CASE ( jpni )
1165
1166	CASE ( 1 ) ! only one proc along i, no mpp exchange
1167
1168	DO ifield = 1, nfields, 1
1169
1170	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
1171
1172	CALL apply_north_fold_jpni1_2dr(list(ifield))
1173
1174	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
1175
1176	CALL apply_north_fold_jpni1_3dr(list(ifield))
1177
1178	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
1179
1180	CALL apply_north_fold_jpni1_2di(list(ifield))
1181
1182	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
1183
1184	CALL apply_north_fold_jpni1_3di(list(ifield))
1185
1186	END IF
1187
1188
1189	END DO ! Loop over fields
1190
1191	CASE DEFAULT ! more than 1 proc along I
1192
1193	DO ifield = 1, nfields, 1
1194	IF( npolj /= 0 .AND. do_nfold )THEN ! only for northern procs.
1195
1196	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
1197
1198	CALL mpp_lbc_north( list(ifield)%r2dptr, list(ifield)%grid, &
1199	REAL(list(ifield)%isgn,wp) )
1200	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
1201	CALL mpp_lbc_north( list(ifield)%r3dptr, list(ifield)%grid, &
1202	REAL(list(ifield)%isgn,wp) )
1203	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
1204	CALL mpp_lbc_north( list(ifield)%i2dptr, list(ifield)%grid, &
1205	list(ifield)%isgn )
1206	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
1207	CALL mpp_lbc_north( list(ifield)%i3dptr, list(ifield)%grid, &
1208	list(ifield)%isgn )
1209	END IF
1210
1211	END IF
1212	END DO
1213
1214	!!$ IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs.
1215
1216	END SELECT ! jpni
1217
1218	END SUBROUTINE apply_north_fold_list
1219
1220	!=========================================================================
1221
1222	SUBROUTINE apply_north_fold_jpni1_2dr(item)
1223	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1224	USE lib_mpp, ONLY: ctl_stop
1225	IMPLICIT None
1226	TYPE (exch_item), INTENT(inout) :: item
1227	! Locals
1228	INTEGER :: iloc, ji, ijt, iju
1229	REAL(wp) :: psgn
1230	REAL(wp), DIMENSION(:,:), POINTER :: b2
1231
1232	!#if defined key_z_first
1233	! CALL ctl_stop('STOP', &
1234	! 'apply_north_fold_jpni1_2dr: key_z_first not implemented for north fold')
1235	! RETURN
1236	!#endif
1237
1238	psgn = REAL(item%isgn, wp)
1239	b2 => item%r2dptr
1240
1241	SELECT CASE ( npolj )
1242
1243	CASE ( 3 , 4 ) ! T pivot
1244	iloc = jpiglo - 2 * ( nimpp - 1 )
1245
1246	SELECT CASE ( item%grid )
1247
1248	CASE ( 'T' , 'S', 'W' )
1249	DO ji = 2, nlci
1250	ijt=iloc-ji+2
1251	b2(ji,nlcj) = psgn * b2(ijt,nlcj-2)
1252	END DO
1253	DO ji = nlci/2+1, nlci
1254	ijt=iloc-ji+2
1255	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1256	END DO
1257
1258	CASE ( 'U' )
1259	DO ji = 1, nlci-1
1260	iju=iloc-ji+1
1261	b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1262	END DO
1263	DO ji = nlci/2, nlci-1
1264	iju=iloc-ji+1
1265	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1266	END DO
1267
1268	CASE ( 'V' )
1269	DO ji = 2, nlci
1270	ijt=iloc-ji+2
1271	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-2)
1272	b2(ji,nlcj ) = psgn * b2(ijt,nlcj-3)
1273	END DO
1274
1275	CASE ( 'F', 'G' )
1276	DO ji = 1, nlci-1
1277	iju=iloc-ji+1
1278	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-2)
1279	b2(ji,nlcj ) = psgn * b2(iju,nlcj-3)
1280	END DO
1281
1282	CASE ( 'I' ) ! ice U-V point
1283	b2(2,nlcj) = psgn * b2(3,nlcj-1)
1284	DO ji = 3, nlci
1285	iju = iloc - ji + 3
1286	b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1287	END DO
1288
1289	END SELECT
1290
1291	CASE ( 5 , 6 ) ! F pivot
1292	iloc=jpiglo-2*(nimpp-1)
1293
1294	SELECT CASE (item%grid)
1295
1296	CASE ( 'T', 'S', 'W' )
1297	DO ji = 1, nlci
1298	ijt=iloc-ji+1
1299	b2(ji,nlcj) = psgn * b2(ijt,nlcj-1)
1300	END DO
1301
1302	CASE ( 'U' )
1303	DO ji = 1, nlci-1
1304	iju=iloc-ji
1305	b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1306	END DO
1307
1308	CASE ( 'V' )
1309	DO ji = 1, nlci
1310	ijt=iloc-ji+1
1311	b2(ji,nlcj ) = psgn * b2(ijt,nlcj-2)
1312	END DO
1313	DO ji = nlci/2+1, nlci
1314	ijt=iloc-ji+1
1315	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1316	END DO
1317
1318	CASE ( 'F', 'G' )
1319	DO ji = 1, nlci-1
1320	iju=iloc-ji
1321	b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1322	END DO
1323	DO ji = nlci/2+1, nlci-1
1324	iju=iloc-ji
1325	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1326	END DO
1327
1328	CASE ( 'I' ) ! ice U-V point
1329	b2( 2 ,nlcj) = 0._wp
1330	DO ji = 2 , nlci-1
1331	ijt = iloc - ji + 2
1332	b2(ji,nlcj)= 0.5 * ( b2(ji,nlcj-1) + psgn * b2(ijt,nlcj-1) )
1333	END DO
1334
1335	END SELECT ! cd_type
1336
1337	END SELECT ! npolj
1338
1339	END SUBROUTINE apply_north_fold_jpni1_2dr
1340
1341	!=========================================================================
1342
1343	SUBROUTINE apply_north_fold_jpni1_3dr(item)
1344	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1345	USE lib_mpp, ONLY: ctl_stop
1346	IMPLICIT None
1347	TYPE (exch_item), INTENT(inout) :: item
1348	!FTRANS b3 :I :I :z
1349	! Locals
1350	INTEGER :: iloc, ji, jk, ijt, iju
1351	REAL(wp) :: psgn
1352	REAL(wp), DIMENSION(:,:,:), POINTER :: b3
1353
1354	!#if defined key_z_first
1355	! CALL ctl_stop('STOP', &
1356	! 'apply_north_fold_jpni1_3dr: key_z_first not implemented for north fold')
1357	! RETURN
1358	!#endif
1359
1360	psgn = REAL(item%isgn, wp)
1361	b3 => item%r3dptr
1362
1363	SELECT CASE ( npolj )
1364
1365	CASE ( 3 , 4 ) ! T pivot
1366	iloc = jpiglo - 2 * ( nimpp - 1 )
1367
1368	SELECT CASE ( item%grid )
1369
1370	CASE ( 'T' , 'S', 'W' )
1371	#if defined key_z_first
1372	DO ji = 2, nlci
1373	DO jk = 1, jpk
1374	ijt=iloc-ji+2
1375	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
1376	END DO
1377	END DO
1378	DO ji = nlci/2+1, nlci
1379	DO jk = 1, jpk
1380	ijt=iloc-ji+2
1381	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1382	END DO
1383	END DO
1384	#else
1385	DO jk = 1, jpk
1386	DO ji = 2, nlci
1387	ijt=iloc-ji+2
1388	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
1389	END DO
1390	DO ji = nlci/2+1, nlci
1391	ijt=iloc-ji+2
1392	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1393	END DO
1394	END DO
1395	#endif
1396
1397	CASE ( 'U' )
1398	#if defined key_z_first
1399	DO ji = 1, nlci-1
1400	DO jk = 1, jpk
1401	iju=iloc-ji+1
1402	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1403	END DO
1404	END DO
1405	DO ji = nlci/2, nlci-1
1406	DO jk = 1, jpk
1407	iju=iloc-ji+1
1408	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1409	END DO
1410	END DO
1411	#else
1412	DO jk = 1, jpk
1413	DO ji = 1, nlci-1
1414	iju=iloc-ji+1
1415	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1416	END DO
1417	DO ji = nlci/2, nlci-1
1418	iju=iloc-ji+1
1419	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1420	END DO
1421	END DO
1422	#endif
1423
1424	CASE ( 'V' )
1425	#if defined key_z_first
1426	DO ji = 2, nlci
1427	DO jk = 1, jpk
1428	#else
1429	DO jk = 1, jpk
1430	DO ji = 2, nlci
1431	#endif
1432	ijt=iloc-ji+2
1433	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-2,jk)
1434	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-3,jk)
1435	END DO
1436	END DO
1437
1438	CASE ( 'F', 'G' )
1439	#if defined key_z_first
1440	DO ji = 1, nlci-1
1441	DO jk = 1, jpk
1442	#else
1443	DO jk = 1, jpk
1444	DO ji = 1, nlci-1
1445	#endif
1446	iju=iloc-ji+1
1447	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-2,jk)
1448	b3(ji,nlcj ,jk) = psgn * b3(iju,nlcj-3,jk)
1449	END DO
1450	END DO
1451
1452	END SELECT
1453
1454	CASE ( 5 , 6 ) ! F pivot
1455	iloc=jpiglo-2*(nimpp-1)
1456
1457	SELECT CASE ( item%grid )
1458
1459	CASE ( 'T' , 'S', 'W' )
1460	#if defined key_z_first
1461	DO ji = 1, nlci
1462	DO jk = 1, jpk
1463	#else
1464	DO jk = 1, jpk
1465	DO ji = 1, nlci
1466	#endif
1467	ijt=iloc-ji+1
1468	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-1,jk)
1469	END DO
1470	END DO
1471
1472	CASE ( 'U' )
1473	#if defined key_z_first
1474	DO ji = 1, nlci-1
1475	DO jk = 1, jpk
1476	#else
1477	DO jk = 1, jpk
1478	DO ji = 1, nlci-1
1479	#endif
1480	iju=iloc-ji
1481	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-1,jk)
1482	END DO
1483	END DO
1484
1485	CASE ( 'V' )
1486	#if defined key_z_first
1487	DO ji = 1, nlci
1488	DO jk = 1, jpk
1489	ijt=iloc-ji+1
1490	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk)
1491	END DO
1492	END DO
1493	DO ji = nlci/2+1, nlci
1494	DO jk = 1, jpk
1495	ijt=iloc-ji+1
1496	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1497	END DO
1498	END DO
1499	#else
1500	DO jk = 1, jpk
1501	DO ji = 1, nlci
1502	ijt=iloc-ji+1
1503	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk)
1504	END DO
1505	DO ji = nlci/2+1, nlci
1506	ijt=iloc-ji+1
1507	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1508	END DO
1509	END DO
1510	#endif
1511
1512	CASE ( 'F', 'G' )
1513	#if defined key_z_first
1514	DO ji = 1, nlci-1
1515	DO jk = 1, jpk
1516	iju=iloc-ji
1517	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1518	END DO
1519	END DO
1520	DO ji = nlci/2+1, nlci-1
1521	DO jk = 1, jpk
1522	iju=iloc-ji
1523	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1524	END DO
1525	END DO
1526	#else
1527	DO jk = 1, jpk
1528	DO ji = 1, nlci-1
1529	iju=iloc-ji
1530	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1531	END DO
1532	DO ji = nlci/2+1, nlci-1
1533	iju=iloc-ji
1534	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1535	END DO
1536	END DO
1537	#endif
1538	END SELECT ! item%grid type
1539
1540	END SELECT ! npolj
1541
1542	END SUBROUTINE apply_north_fold_jpni1_3dr
1543
1544	!=========================================================================
1545
1546	SUBROUTINE apply_north_fold_jpni1_2di(item)
1547	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1548	USE lib_mpp, ONLY: ctl_stop
1549	IMPLICIT None
1550	TYPE (exch_item), INTENT(inout) :: item
1551	! Locals
1552	INTEGER :: iloc, ji, ijt, iju
1553	INTEGER :: isgn
1554	INTEGER, DIMENSION(:,:), POINTER :: ib2
1555
1556	isgn = item%isgn
1557	ib2 => item%i2dptr
1558
1559	SELECT CASE ( npolj )
1560
1561	CASE ( 3 , 4 ) ! T pivot
1562	iloc = jpiglo - 2 * ( nimpp - 1 )
1563
1564	SELECT CASE ( item%grid )
1565
1566	CASE ( 'T' , 'S', 'W' )
1567	DO ji = 2, nlci
1568	ijt=iloc-ji+2
1569	ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-2)
1570	END DO
1571	DO ji = nlci/2+1, nlci
1572	ijt=iloc-ji+2
1573	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
1574	END DO
1575
1576	CASE ( 'U' )
1577	DO ji = 1, nlci-1
1578	iju=iloc-ji+1
1579	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
1580	END DO
1581	DO ji = nlci/2, nlci-1
1582	iju=iloc-ji+1
1583	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
1584	END DO
1585
1586	CASE ( 'V' )
1587	DO ji = 2, nlci
1588	ijt=iloc-ji+2
1589	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-2)
1590	ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-3)
1591	END DO
1592
1593	CASE ( 'F', 'G' )
1594	DO ji = 1, nlci-1
1595	iju=iloc-ji+1
1596	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-2)
1597	ib2(ji,nlcj ) = isgn * ib2(iju,nlcj-3)
1598	END DO
1599
1600	CASE ( 'I' ) ! ice U-V point
1601	ib2(2,nlcj) = isgn * ib2(3,nlcj-1)
1602	DO ji = 3, nlci
1603	iju = iloc - ji + 3
1604	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
1605	END DO
1606
1607	END SELECT
1608
1609	CASE ( 5 , 6 ) ! F pivot
1610	iloc=jpiglo-2*(nimpp-1)
1611
1612	SELECT CASE (item%grid)
1613
1614	CASE ( 'T', 'S', 'W' )
1615	DO ji = 1, nlci
1616	ijt=iloc-ji+1
1617	ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-1)
1618	END DO
1619
1620	CASE ( 'U' )
1621	DO ji = 1, nlci-1
1622	iju=iloc-ji
1623	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
1624	END DO
1625
1626	CASE ( 'V' )
1627	DO ji = 1, nlci
1628	ijt=iloc-ji+1
1629	ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-2)
1630	END DO
1631	DO ji = nlci/2+1, nlci
1632	ijt=iloc-ji+1
1633	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
1634	END DO
1635
1636	CASE ( 'F', 'G' )
1637	DO ji = 1, nlci-1
1638	iju=iloc-ji
1639	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
1640	END DO
1641	DO ji = nlci/2+1, nlci-1
1642	iju=iloc-ji
1643	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
1644	END DO
1645
1646	CASE ( 'I' ) ! ice U-V point
1647	ib2( 2 ,nlcj) = 0._wp
1648	DO ji = 2 , nlci-1
1649	ijt = iloc - ji + 2
1650	ib2(ji,nlcj)= INT(0.5 * ( ib2(ji,nlcj-1) + isgn * ib2(ijt,nlcj-1) ))
1651	END DO
1652
1653	END SELECT ! cd_type
1654
1655	END SELECT ! npolj
1656
1657	END SUBROUTINE apply_north_fold_jpni1_2di
1658
1659	!=========================================================================
1660
1661	SUBROUTINE apply_north_fold_jpni1_3di(item)
1662	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1663	USE lib_mpp, ONLY: ctl_stop
1664	IMPLICIT None
1665	TYPE (exch_item), INTENT(inout) :: item
1666	!FTRANS ib3 :I :I :z
1667	! Locals
1668	INTEGER :: iloc, ji, ijt, iju, jk
1669	INTEGER :: isgn
1670	INTEGER, DIMENSION(:,:,:), POINTER :: ib3
1671
1672	isgn = item%isgn
1673	ib3 => item%i3dptr
1674
1675	SELECT CASE ( npolj )
1676
1677	CASE ( 3 , 4 ) ! T pivot
1678	iloc = jpiglo - 2 * ( nimpp - 1 )
1679
1680	SELECT CASE ( item%grid )
1681
1682	CASE ( 'T' , 'S', 'W' )
1683	#if defined key_z_first
1684	DO ji = 2, nlci
1685	DO jk = 1, jpk
1686	ijt=iloc-ji+2
1687	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
1688	END DO
1689	END DO
1690	DO ji = nlci/2+1, nlci
1691	DO jk = 1, jpk
1692	ijt=iloc-ji+2
1693	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1694	END DO
1695	END DO
1696	#else
1697	DO jk = 1, jpk
1698	DO ji = 2, nlci
1699	ijt=iloc-ji+2
1700	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
1701	END DO
1702	DO ji = nlci/2+1, nlci
1703	ijt=iloc-ji+2
1704	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1705	END DO
1706	END DO
1707	#endif
1708
1709	CASE ( 'U' )
1710	#if defined key_z_first
1711	DO ji = 1, nlci-1
1712	DO jk = 1, jpk
1713	iju=iloc-ji+1
1714	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1715	END DO
1716	END DO
1717	DO ji = nlci/2, nlci-1
1718	DO jk = 1, jpk
1719	iju=iloc-ji+1
1720	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1721	END DO
1722	END DO
1723	#else
1724	DO jk = 1, jpk
1725	DO ji = 1, nlci-1
1726	iju=iloc-ji+1
1727	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1728	END DO
1729	DO ji = nlci/2, nlci-1
1730	iju=iloc-ji+1
1731	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1732	END DO
1733	END DO
1734	#endif
1735
1736	CASE ( 'V' )
1737	#if defined key_z_first
1738	DO ji = 2, nlci
1739	DO jk = 1, jpk
1740	#else
1741	DO jk = 1, jpk
1742	DO ji = 2, nlci
1743	#endif
1744	ijt=iloc-ji+2
1745	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-2,jk)
1746	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-3,jk)
1747	END DO
1748	END DO
1749
1750	CASE ( 'F', 'G' )
1751	#if defined key_z_first
1752	DO ji = 1, nlci-1
1753	DO jk = 1, jpk
1754	#else
1755	DO jk = 1, jpk
1756	DO ji = 1, nlci-1
1757	#endif
1758	iju=iloc-ji+1
1759	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-2,jk)
1760	ib3(ji,nlcj ,jk) = isgn * ib3(iju,nlcj-3,jk)
1761	END DO
1762	END DO
1763
1764	END SELECT
1765
1766	CASE ( 5 , 6 ) ! F pivot
1767	iloc=jpiglo-2*(nimpp-1)
1768
1769	SELECT CASE ( item%grid )
1770
1771	CASE ( 'T' , 'S', 'W' )
1772	#if defined key_z_first
1773	DO ji = 1, nlci
1774	DO jk = 1, jpk
1775	#else
1776	DO jk = 1, jpk
1777	DO ji = 1, nlci
1778	#endif
1779	ijt=iloc-ji+1
1780	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-1,jk)
1781	END DO
1782	END DO
1783
1784	CASE ( 'U' )
1785	#if defined key_z_first
1786	DO ji = 1, nlci-1
1787	DO jk = 1, jpk
1788	#else
1789	DO jk = 1, jpk
1790	DO ji = 1, nlci-1
1791	#endif
1792	iju=iloc-ji
1793	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-1,jk)
1794	END DO
1795	END DO
1796
1797	CASE ( 'V' )
1798	#if defined key_z_first
1799	DO ji = 1, nlci
1800	DO jk = 1, jpk
1801	ijt=iloc-ji+1
1802	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk)
1803	END DO
1804	END DO
1805	DO ji = nlci/2+1, nlci
1806	DO jk = 1, jpk
1807	ijt=iloc-ji+1
1808	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1809	END DO
1810	END DO
1811	#else
1812	DO jk = 1, jpk
1813	DO ji = 1, nlci
1814	ijt=iloc-ji+1
1815	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk)
1816	END DO
1817	DO ji = nlci/2+1, nlci
1818	ijt=iloc-ji+1
1819	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1820	END DO
1821	END DO
1822	#endif
1823
1824	CASE ( 'F', 'G' )
1825	#if defined key_z_first
1826	DO ji = 1, nlci-1
1827	DO jk = 1, jpk
1828	iju=iloc-ji
1829	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1830	END DO
1831	END DO
1832	DO ji = nlci/2+1, nlci-1
1833	DO jk = 1, jpk
1834	iju=iloc-ji
1835	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1836	END DO
1837	END DO
1838	#else
1839	DO jk = 1, jpk
1840	DO ji = 1, nlci-1
1841	iju=iloc-ji
1842	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1843	END DO
1844	DO ji = nlci/2+1, nlci-1
1845	iju=iloc-ji
1846	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1847	END DO
1848	END DO
1849	#endif
1850	END SELECT ! item%grid type
1851
1852	END SELECT ! npolj
1853
1854	END SUBROUTINE apply_north_fold_jpni1_3di
1855
1856	!=========================================================================
1857
1858	SUBROUTINE apply_north_fold2(b2, isgn, cd_type)
1859	USE par_oce, ONLY: wp, jpni, jpk
1860	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1861	USE lib_mpp, ONLY: ctl_stop
1862	IMPLICIT none
1863	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(1:, 1:) :: b2
1864	INTEGER, INTENT(in) :: isgn
1865	CHARACTER (LEN=1), INTENT(in) :: cd_type
1866	! Local variables
1867	INTEGER :: ji, ijt, iju, iloc
1868	REAL(wp) :: psgn
1869
1870	psgn = REAL(isgn, wp)
1871
1872	! Treatment without exchange (jpni odd)
1873
1874	SELECT CASE ( jpni )
1875
1876	CASE ( 1 ) ! only one proc along I, no mpp exchange
1877
1878	SELECT CASE ( npolj )
1879
1880	CASE ( 3 , 4 ) ! T pivot
1881	iloc = jpiglo - 2 * ( nimpp - 1 )
1882
1883	SELECT CASE ( cd_type )
1884
1885	CASE ( 'T' , 'S', 'W' )
1886	DO ji = 2, nlci
1887	ijt=iloc-ji+2
1888	b2(ji,nlcj) = psgn * b2(ijt,nlcj-2)
1889	END DO
1890	DO ji = nlci/2+1, nlci
1891	ijt=iloc-ji+2
1892	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1893	END DO
1894
1895	CASE ( 'U' )
1896	DO ji = 1, nlci-1
1897	iju=iloc-ji+1
1898	b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1899	END DO
1900	DO ji = nlci/2, nlci-1
1901	iju=iloc-ji+1
1902	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1903	END DO
1904
1905	CASE ( 'V' )
1906	DO ji = 2, nlci
1907	ijt=iloc-ji+2
1908	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-2)
1909	b2(ji,nlcj ) = psgn * b2(ijt,nlcj-3)
1910	END DO
1911
1912	CASE ( 'F', 'G' )
1913	DO ji = 1, nlci-1
1914	iju=iloc-ji+1
1915	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-2)
1916	b2(ji,nlcj ) = psgn * b2(iju,nlcj-3)
1917	END DO
1918
1919	CASE ( 'I' ) ! ice U-V point
1920	b2(2,nlcj) = psgn * b2(3,nlcj-1)
1921	DO ji = 3, nlci
1922	iju = iloc - ji + 3
1923	b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1924	END DO
1925
1926	END SELECT
1927
1928	CASE ( 5 , 6 ) ! F pivot
1929	iloc=jpiglo-2*(nimpp-1)
1930
1931	SELECT CASE (cd_type )
1932
1933	CASE ( 'T', 'S', 'W' )
1934	DO ji = 1, nlci
1935	ijt=iloc-ji+1
1936	b2(ji,nlcj) = psgn * b2(ijt,nlcj-1)
1937	END DO
1938
1939	CASE ( 'U' )
1940	DO ji = 1, nlci-1
1941	iju=iloc-ji
1942	b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1943	END DO
1944
1945	CASE ( 'V' )
1946	DO ji = 1, nlci
1947	ijt=iloc-ji+1
1948	b2(ji,nlcj ) = psgn * b2(ijt,nlcj-2)
1949	END DO
1950	DO ji = nlci/2+1, nlci
1951	ijt=iloc-ji+1
1952	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1953	END DO
1954
1955	CASE ( 'F', 'G' )
1956	DO ji = 1, nlci-1
1957	iju=iloc-ji
1958	b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1959	END DO
1960	DO ji = nlci/2+1, nlci-1
1961	iju=iloc-ji
1962	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1963	END DO
1964
1965	CASE ( 'I' ) ! ice U-V point
1966	b2( 2 ,nlcj) = 0._wp
1967	DO ji = 2 , nlci-1
1968	ijt = iloc - ji + 2
1969	b2(ji,nlcj)= 0.5 * ( b2(ji,nlcj-1) + psgn * b2(ijt,nlcj-1) )
1970	END DO
1971
1972	END SELECT ! cd_type
1973
1974	END SELECT ! npolj
1975
1976	CASE DEFAULT ! more than 1 proc along I
1977	IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north( b2, cd_type, psgn ) ! only for northern procs.
1978
1979	END SELECT ! jpni
1980
1981	END SUBROUTINE apply_north_fold2
1982
1983	!=========================================================================
1984
1985	SUBROUTINE apply_north_fold2i(ib2, isgn, cd_type)
1986	USE par_oce, ONLY: wp, jpni, jpk
1987	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1988	USE lib_mpp, ONLY: ctl_stop
1989	IMPLICIT none
1990	INTEGER, INTENT(inout), DIMENSION(1:, 1:) :: ib2
1991	INTEGER, INTENT(in) :: isgn
1992	CHARACTER (LEN=1), INTENT(in) :: cd_type
1993	! Local variables
1994	INTEGER :: ji, ijt, iju, iloc
1995
1996
1997	#if defined key_z_first
1998	CALL ctl_stop('STOP', &
1999	'apply_north_fold2i: key_z_first not implemented for north fold')
2000	RETURN
2001	#endif
2002
2003	! Treatment without exchange (jpni odd)
2004
2005	SELECT CASE ( jpni )
2006
2007	CASE ( 1 ) ! only one proc along I, no mpp exchange
2008
2009	SELECT CASE ( npolj )
2010
2011	CASE ( 3 , 4 ) ! T pivot
2012	iloc = jpiglo - 2 * ( nimpp - 1 )
2013
2014	SELECT CASE ( cd_type )
2015
2016	CASE ( 'T' , 'S', 'W' )
2017	DO ji = 2, nlci
2018	ijt=iloc-ji+2
2019	ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-2)
2020	END DO
2021	DO ji = nlci/2+1, nlci
2022	ijt=iloc-ji+2
2023	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
2024	END DO
2025
2026	CASE ( 'U' )
2027	DO ji = 1, nlci-1
2028	iju=iloc-ji+1
2029	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
2030	END DO
2031	DO ji = nlci/2, nlci-1
2032	iju=iloc-ji+1
2033	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
2034	END DO
2035
2036	CASE ( 'V' )
2037	DO ji = 2, nlci
2038	ijt=iloc-ji+2
2039	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-2)
2040	ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-3)
2041	END DO
2042
2043	CASE ( 'F', 'G' )
2044	DO ji = 1, nlci-1
2045	iju=iloc-ji+1
2046	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-2)
2047	ib2(ji,nlcj ) = isgn * ib2(iju,nlcj-3)
2048	END DO
2049
2050	CASE ( 'I' ) ! ice U-V point
2051	ib2(2,nlcj) = isgn * ib2(3,nlcj-1)
2052	DO ji = 3, nlci
2053	iju = iloc - ji + 3
2054	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
2055	END DO
2056
2057	END SELECT
2058
2059	CASE ( 5 , 6 ) ! F pivot
2060	iloc=jpiglo-2*(nimpp-1)
2061
2062	SELECT CASE (cd_type )
2063
2064	CASE ( 'T', 'S', 'W' )
2065	DO ji = 1, nlci
2066	ijt=iloc-ji+1
2067	ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-1)
2068	END DO
2069
2070	CASE ( 'U' )
2071	DO ji = 1, nlci-1
2072	iju=iloc-ji
2073	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
2074	END DO
2075
2076	CASE ( 'V' )
2077	DO ji = 1, nlci
2078	ijt=iloc-ji+1
2079	ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-2)
2080	END DO
2081	DO ji = nlci/2+1, nlci
2082	ijt=iloc-ji+1
2083	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
2084	END DO
2085
2086	CASE ( 'F', 'G' )
2087	DO ji = 1, nlci-1
2088	iju=iloc-ji
2089	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
2090	END DO
2091	DO ji = nlci/2+1, nlci-1
2092	iju=iloc-ji
2093	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
2094	END DO
2095
2096	CASE ( 'I' ) ! ice U-V point
2097	ib2( 2 ,nlcj) = 0._wp
2098	DO ji = 2 , nlci-1
2099	ijt = iloc - ji + 2
2100	ib2(ji,nlcj)= INT(0.5 * ( ib2(ji,nlcj-1) + isgn * ib2(ijt,nlcj-1) ))
2101	END DO
2102
2103	END SELECT ! cd_type
2104
2105	END SELECT ! npolj
2106
2107	CASE DEFAULT ! more than 1 proc along I
2108	IF( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north( ib2, cd_type, isgn ) ! only for northern procs.
2109
2110	END SELECT ! jpni
2111
2112	END SUBROUTINE apply_north_fold2i
2113
2114	!=========================================================================
2115
2116	SUBROUTINE apply_north_fold3(b3, isgn, cd_type)
2117	USE par_oce, ONLY: wp, jpni, jpk
2118	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
2119	USE lib_mpp, ONLY: ctl_stop
2120	IMPLICIT none
2121	!FTRANS b3 :I :I :z
2122	REAL(wp), INTENT(inout), DIMENSION(1:, 1:, 1:) :: b3
2123	INTEGER, INTENT(in) :: isgn
2124	CHARACTER (LEN=1), INTENT(in) :: cd_type
2125	! Local variables
2126	INTEGER :: ji, jk, ijt, iju, iloc
2127	REAL(wp) :: psgn
2128	!!----------------------------------------------------------------------
2129
2130	psgn = REAL(isgn, wp)
2131
2132	! Treatment without exchange (jpni odd)
2133	! T-point pivot
2134
2135	SELECT CASE ( jpni )
2136
2137	CASE ( 1 ) ! only one proc along I, no mpp exchange
2138
2139	SELECT CASE ( npolj )
2140
2141	CASE ( 3 , 4 ) ! T pivot
2142	iloc = jpiglo - 2 * ( nimpp - 1 )
2143
2144	SELECT CASE ( cd_type )
2145
2146	CASE ( 'T' , 'S', 'W' )
2147	#if defined key_z_first
2148	DO ji = 2, nlci
2149	DO jk = 1, jpk
2150	ijt=iloc-ji+2
2151	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
2152	END DO
2153	END DO
2154	DO ji = nlci/2+1, nlci
2155	DO jk = 1, jpk
2156	ijt=iloc-ji+2
2157	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2158	END DO
2159	END DO
2160	#else
2161	DO jk = 1, jpk
2162	DO ji = 2, nlci
2163	ijt=iloc-ji+2
2164	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
2165	END DO
2166	DO ji = nlci/2+1, nlci
2167	ijt=iloc-ji+2
2168	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2169	END DO
2170	END DO
2171	#endif
2172
2173	CASE ( 'U' )
2174	#if defined key_z_first
2175	DO ji = 1, nlci-1
2176	DO jk = 1, jpk
2177	iju=iloc-ji+1
2178	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2179	END DO
2180	END DO
2181	DO ji = nlci/2, nlci-1
2182	DO jk = 1, jpk
2183	iju=iloc-ji+1
2184	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2185	END DO
2186	END DO
2187	#else
2188	DO jk = 1, jpk
2189	DO ji = 1, nlci-1
2190	iju=iloc-ji+1
2191	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2192	END DO
2193	DO ji = nlci/2, nlci-1
2194	iju=iloc-ji+1
2195	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2196	END DO
2197	END DO
2198	#endif
2199
2200	CASE ( 'V' )
2201	#if defined key_z_first
2202	DO ji = 2, nlci
2203	DO jk = 1, jpk
2204	#else
2205	DO jk = 1, jpk
2206	DO ji = 2, nlci
2207	#endif
2208	ijt=iloc-ji+2
2209	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-2,jk)
2210	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-3,jk)
2211	END DO
2212	END DO
2213
2214	CASE ( 'F', 'G' )
2215	#if defined key_z_first
2216	DO ji = 1, nlci-1
2217	DO jk = 1, jpk
2218	#else
2219	DO jk = 1, jpk
2220	DO ji = 1, nlci-1
2221	#endif
2222	iju=iloc-ji+1
2223	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-2,jk)
2224	b3(ji,nlcj ,jk) = psgn * b3(iju,nlcj-3,jk)
2225	END DO
2226	END DO
2227
2228	END SELECT
2229
2230	CASE ( 5 , 6 ) ! F pivot
2231	iloc=jpiglo-2*(nimpp-1)
2232
2233	SELECT CASE ( cd_type )
2234
2235	CASE ( 'T' , 'S', 'W' )
2236	#if defined key_z_first
2237	DO ji = 1, nlci
2238	DO jk = 1, jpk
2239	#else
2240	DO jk = 1, jpk
2241	DO ji = 1, nlci
2242	#endif
2243	ijt=iloc-ji+1
2244	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-1,jk)
2245	END DO
2246	END DO
2247
2248	CASE ( 'U' )
2249	#if defined key_z_first
2250	DO ji = 1, nlci-1
2251	DO jk = 1, jpk
2252	#else
2253	DO jk = 1, jpk
2254	DO ji = 1, nlci-1
2255	#endif
2256	iju=iloc-ji
2257	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-1,jk)
2258	END DO
2259	END DO
2260
2261	CASE ( 'V' )
2262	#if defined key_z_first
2263	DO ji = 1, nlci
2264	DO jk = 1, jpk
2265	ijt=iloc-ji+1
2266	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk)
2267	END DO
2268	END DO
2269	DO ji = nlci/2+1, nlci
2270	DO jk = 1, jpk
2271	ijt=iloc-ji+1
2272	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2273	END DO
2274	END DO
2275	#else
2276	DO jk = 1, jpk
2277	DO ji = 1, nlci
2278	ijt=iloc-ji+1
2279	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk)
2280	END DO
2281	DO ji = nlci/2+1, nlci
2282	ijt=iloc-ji+1
2283	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2284	END DO
2285	END DO
2286	#endif
2287
2288	CASE ( 'F', 'G' )
2289	#if defined key_z_first
2290	DO ji = 1, nlci-1
2291	DO jk = 1, jpk
2292	iju=iloc-ji
2293	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2294	END DO
2295	END DO
2296	DO ji = nlci/2+1, nlci-1
2297	DO jk = 1, jpk
2298	iju=iloc-ji
2299	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2300	END DO
2301	END DO
2302	#else
2303	DO jk = 1, jpk
2304	DO ji = 1, nlci-1
2305	iju=iloc-ji
2306	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2307	END DO
2308	DO ji = nlci/2+1, nlci-1
2309	iju=iloc-ji
2310	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2311	END DO
2312	END DO
2313	#endif
2314	END SELECT ! cd_type
2315
2316	END SELECT ! npolj
2317
2318	CASE DEFAULT ! more than 1 proc along I
2319	IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs.
2320
2321	END SELECT ! jpni
2322
2323	END SUBROUTINE apply_north_fold3
2324
2325	!=========================================================================
2326
2327	SUBROUTINE apply_north_fold3i(ib3, isgn, cd_type)
2328	USE par_oce, ONLY: wp, jpni, jpk
2329	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
2330	USE lib_mpp, ONLY: ctl_stop
2331	IMPLICIT none
2332	!FTRANS ib3 :I :I :z
2333	INTEGER, INTENT(inout), DIMENSION(1:, 1:, :) :: ib3
2334	INTEGER, INTENT(in) :: isgn
2335	CHARACTER (LEN=1), INTENT(in) :: cd_type
2336	! Local variables
2337	INTEGER :: ji, jk, ijt, iju, iloc
2338
2339	! 4.1 treatment without exchange (jpni odd)
2340	! T-point pivot
2341
2342	SELECT CASE ( jpni )
2343
2344	CASE ( 1 ) ! only one proc along I, no mpp exchange
2345
2346	SELECT CASE ( npolj )
2347
2348	CASE ( 3 , 4 ) ! T pivot
2349	iloc = jpiglo - 2 * ( nimpp - 1 )
2350
2351	SELECT CASE ( cd_type )
2352
2353	CASE ( 'T' , 'S', 'W' )
2354	#if defined key_z_first
2355	DO ji = 2, nlci
2356	DO jk = 1, jpk
2357	ijt=iloc-ji+2
2358	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
2359	END DO
2360	END DO
2361	DO ji = nlci/2+1, nlci
2362	DO jk = 1, jpk
2363	ijt=iloc-ji+2
2364	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2365	END DO
2366	END DO
2367	#else
2368	DO jk = 1, jpk
2369	DO ji = 2, nlci
2370	ijt=iloc-ji+2
2371	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
2372	END DO
2373	DO ji = nlci/2+1, nlci
2374	ijt=iloc-ji+2
2375	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2376	END DO
2377	END DO
2378	#endif
2379
2380	CASE ( 'U' )
2381	#if defined key_z_first
2382	DO ji = 1, nlci-1
2383	DO jk = 1, jpk
2384	iju=iloc-ji+1
2385	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2386	END DO
2387	END DO
2388	DO ji = nlci/2, nlci-1
2389	DO jk = 1, jpk
2390	iju=iloc-ji+1
2391	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2392	END DO
2393	END DO
2394	#else
2395	DO jk = 1, jpk
2396	DO ji = 1, nlci-1
2397	iju=iloc-ji+1
2398	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2399	END DO
2400	DO ji = nlci/2, nlci-1
2401	iju=iloc-ji+1
2402	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2403	END DO
2404	END DO
2405	#endif
2406
2407	CASE ( 'V' )
2408	#if defined key_z_first
2409	DO ji = 2, nlci
2410	DO jk = 1, jpk
2411	#else
2412	DO jk = 1, jpk
2413	DO ji = 2, nlci
2414	#endif
2415	ijt=iloc-ji+2
2416	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-2,jk)
2417	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-3,jk)
2418	END DO
2419	END DO
2420
2421	CASE ( 'F', 'G' )
2422	#if defined key_z_first
2423	DO ji = 1, nlci-1
2424	DO jk = 1, jpk
2425	#else
2426	DO jk = 1, jpk
2427	DO ji = 1, nlci-1
2428	#endif
2429	iju=iloc-ji+1
2430	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-2,jk)
2431	ib3(ji,nlcj ,jk) = isgn * ib3(iju,nlcj-3,jk)
2432	END DO
2433	END DO
2434
2435	END SELECT
2436
2437	CASE ( 5 , 6 ) ! F pivot
2438	iloc=jpiglo-2*(nimpp-1)
2439
2440	SELECT CASE ( cd_type )
2441
2442	CASE ( 'T' , 'S', 'W' )
2443	#if defined key_z_first
2444	DO ji = 1, nlci
2445	DO jk = 1, jpk
2446	#else
2447	DO jk = 1, jpk
2448	DO ji = 1, nlci
2449	#endif
2450	ijt=iloc-ji+1
2451	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-1,jk)
2452	END DO
2453	END DO
2454
2455	CASE ( 'U' )
2456	#if defined key_z_first
2457	DO ji = 1, nlci-1
2458	DO jk = 1, jpk
2459	#else
2460	DO jk = 1, jpk
2461	DO ji = 1, nlci-1
2462	#endif
2463	iju=iloc-ji
2464	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-1,jk)
2465	END DO
2466	END DO
2467
2468	CASE ( 'V' )
2469	#if defined key_z_first
2470	DO ji = 1, nlci
2471	DO jk = 1, jpk
2472	ijt=iloc-ji+1
2473	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk)
2474	END DO
2475	END DO
2476	DO ji = nlci/2+1, nlci
2477	DO jk = 1, jpk
2478	ijt=iloc-ji+1
2479	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2480	END DO
2481	END DO
2482	#else
2483	DO jk = 1, jpk
2484	DO ji = 1, nlci
2485	ijt=iloc-ji+1
2486	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk)
2487	END DO
2488	DO ji = nlci/2+1, nlci
2489	ijt=iloc-ji+1
2490	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2491	END DO
2492	END DO
2493	#endif
2494
2495	CASE ( 'F', 'G' )
2496	#if defined key_z_first
2497	DO ji = 1, nlci-1
2498	DO jk = 1, jpk
2499	iju=iloc-ji
2500	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2501	END DO
2502	END DO
2503	DO ji = nlci/2+1, nlci-1
2504	DO jk = 1, jpk
2505	iju=iloc-ji
2506	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2507	END DO
2508	END DO
2509	#else
2510	DO jk = 1, jpk
2511	DO ji = 1, nlci-1
2512	iju=iloc-ji
2513	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2514	END DO
2515	DO ji = nlci/2+1, nlci-1
2516	iju=iloc-ji
2517	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2518	END DO
2519	END DO
2520	#endif
2521
2522	END SELECT ! cd_type
2523
2524	END SELECT ! npolj
2525
2526	CASE DEFAULT ! more than 1 proc along I
2527	IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs.
2528
2529	END SELECT ! jpni
2530
2531	END SUBROUTINE apply_north_fold3i
2532
2533	!================================================================
2534
2535	SUBROUTINE add_exch(iwidth, grid, dirn1, &
2536	dirn2, dirn3, dirn4, &
2537	r2d, r3d, i2d, i3d, isgn, lfill)
2538	USE lib_mpp, ONLY: ctl_stop
2539	IMPLICIT none
2540	! Arguments
2541	INTEGER :: iwidth, dirn1, dirn2, dirn3, dirn4
2542	CHARACTER (LEN=1) :: grid
2543	REAL(wp), DIMENSION(:,:), TARGET, OPTIONAL :: r2d
2544	REAL(wp), DIMENSION(:,:,:), TARGET, OPTIONAL :: r3d
2545	INTEGER, DIMENSION(:,:), TARGET, OPTIONAL :: i2d
2546	INTEGER, DIMENSION(:,:,:), TARGET, OPTIONAL :: i3d
2547	INTEGER, OPTIONAL :: isgn
2548	LOGICAL, OPTIONAL :: lfill
2549	! Local vars
2550	!!--------------------------------------------------------------------
2551
2552	#if ! defined key_mpp_rkpart
2553	RETURN
2554	#endif
2555
2556	IF(nextFreeExchItem > maxExchItems)THEN
2557	CALL ctl_stop('STOP','ARPDBG: implement reallocate in add_exch')
2558	RETURN
2559	END IF
2560
2561	exch_list(nextFreeExchItem)%halo_width = iwidth
2562
2563	exch_list(nextFreeExchItem)%dirn(1) = dirn1
2564	exch_list(nextFreeExchItem)%dirn(2) = dirn2
2565	exch_list(nextFreeExchItem)%dirn(3) = dirn3
2566	exch_list(nextFreeExchItem)%dirn(4) = dirn4
2567
2568	exch_list(nextFreeExchItem)%grid = grid
2569
2570	IF(PRESENT(isgn))THEN
2571	exch_list(nextFreeExchItem)%isgn = isgn
2572	ELSE
2573	exch_list(nextFreeExchItem)%isgn = 1
2574	END IF
2575
2576	NULLIFY( exch_list(nextFreeExchItem)%r2dptr, &
2577	exch_list(nextFreeExchItem)%r3dptr, &
2578	exch_list(nextFreeExchItem)%i2dptr, &
2579	exch_list(nextFreeExchItem)%i3dptr )
2580
2581	IF(PRESENT(r2d))THEN
2582	exch_list(nextFreeExchItem)%r2dptr => r2d
2583	ELSE IF(PRESENT(r3d))THEN
2584	exch_list(nextFreeExchItem)%r3dptr => r3d
2585	ELSE IF(PRESENT(i2d))THEN
2586	exch_list(nextFreeExchItem)%i2dptr => i2d
2587	ELSE IF(PRESENT(i3d))THEN
2588	exch_list(nextFreeExchItem)%i3dptr => i3d
2589	ELSE
2590	! This section is both for error checking and allows me to be lazy in the
2591	! testing code - I don't have to check which arrays I've been passed
2592	! before I call this routine.
2593	WRITE (,) 'WARNING: add_exch called without a ptr to an array - will be ignored'
2594	RETURN
2595	END IF
2596
2597	IF(PRESENT(lfill))THEN
2598	exch_list(nextFreeExchItem)%lfill = lfill
2599	ELSE
2600	exch_list(nextFreeExchItem)%lfill = .false.
2601	END IF
2602
2603	nextFreeExchItem = nextFreeExchItem + 1
2604
2605	END SUBROUTINE add_exch
2606
2607	!================================================================
2608
2609	SUBROUTINE wipe_exch(item)
2610	IMPLICIT none
2611	! Arguments
2612	TYPE (exch_item), INTENT(inout) :: item
2613
2614	NULLIFY(item%i2dptr, item%r2dptr, item%i3dptr, item%r3dptr)
2615	item%isgn = 1
2616
2617	END SUBROUTINE wipe_exch
2618
2619	!================================================================
2620
2621	SUBROUTINE bound_exch2 (b, nhalo, nhexch, &
2622	comm1, comm2, comm3, comm4, &
2623	cd_type, lfill, pval, isgn, lzero )
2624	!!----------------------------------------------------------------------
2625	!!----------------------------------------------------------------------
2626	USE par_oce, ONLY : wp
2627	IMPLICIT none
2628	REAL(wp), INTENT(inout), DIMENSION(:,:) :: b
2629	INTEGER, INTENT(in) :: nhalo,nhexch
2630	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
2631	CHARACTER (LEN=1), INTENT(in) :: cd_type
2632	LOGICAL, OPTIONAL, INTENT(in) :: lfill
2633	INTEGER, OPTIONAL, INTENT(in) :: isgn
2634	LOGICAL, OPTIONAL, INTENT(in) :: lzero
2635	REAL(wp),OPTIONAL, INTENT(in) :: pval
2636
2637	CALL bound_exch_generic( b2=b,nhalo=nhalo,nhexch=nhexch, &
2638	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2639	cd_type=cd_type, lfill=lfill, pval=pval, &
2640	isgn=isgn, lzero=lzero )
2641	RETURN
2642	END SUBROUTINE bound_exch2
2643
2644
2645	SUBROUTINE bound_exch2i (b, nhalo, nhexch, comm1, comm2, comm3, comm4, &
2646	cd_type, lfill, pval, isgn, lzero )
2647	!!----------------------------------------------------------------------
2648	!!----------------------------------------------------------------------
2649	USE par_oce, ONLY: wp
2650	IMPLICIT none
2651	INTEGER, INTENT(inout), DIMENSION(:,:) :: b
2652	INTEGER, INTENT(in) :: nhalo,nhexch
2653	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
2654	CHARACTER (LEN=1), INTENT(in) :: cd_type
2655	LOGICAL, OPTIONAL, INTENT(in) :: lfill
2656	INTEGER, OPTIONAL, INTENT(in) :: isgn
2657	LOGICAL, OPTIONAL, INTENT(in) :: lzero
2658	REAL(wp),OPTIONAL, INTENT(in) :: pval
2659
2660	CALL bound_exch_generic (ib2=b,nhalo=nhalo,nhexch=nhexch, &
2661	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2662	cd_type=cd_type, lfill=lfill, pval=pval, &
2663	isgn=isgn, lzero=lzero )
2664	RETURN
2665	END SUBROUTINE bound_exch2i
2666
2667
2668	SUBROUTINE bound_exch3 (b, nhalo, nhexch, comm1, comm2, comm3, &
2669	comm4, cd_type, lfill, pval, isgn, lzero)
2670	!!----------------------------------------------------------------------
2671	!!----------------------------------------------------------------------
2672	USE par_oce, ONLY: wp
2673	IMPLICIT none
2674	REAL(wp), INTENT(inout), DIMENSION(:,:,:) :: b
2675	INTEGER, INTENT(in) :: nhalo,nhexch
2676	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
2677	CHARACTER (LEN=1), INTENT(in) :: cd_type
2678	LOGICAL, OPTIONAL, INTENT(in) :: lfill
2679	INTEGER, OPTIONAL, INTENT(in) :: isgn
2680	LOGICAL, OPTIONAL, INTENT(in) :: lzero
2681	REAL(wp),OPTIONAL, INTENT(in) :: pval
2682
2683	CALL bound_exch_generic ( b3=b,nhalo=nhalo,nhexch=nhexch,&
2684	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2685	cd_type=cd_type, lfill=lfill, pval=pval, &
2686	isgn=isgn, lzero=lzero )
2687	RETURN
2688	END SUBROUTINE bound_exch3
2689
2690
2691	SUBROUTINE bound_exch3i (b, nhalo, nhexch, comm1, comm2, comm3, &
2692	comm4, cd_type, lfill, pval, isgn, lzero)
2693	!!----------------------------------------------------------------------
2694	!!----------------------------------------------------------------------
2695	IMPLICIT none
2696	INTEGER, INTENT(inout), DIMENSION(:,:,:) :: b
2697	INTEGER, INTENT(in) :: nhalo,nhexch
2698	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
2699	CHARACTER (LEN=1), INTENT(in) :: cd_type
2700	LOGICAL, OPTIONAL, INTENT(in) :: lfill
2701	INTEGER, OPTIONAL, INTENT(in) :: isgn
2702	LOGICAL, OPTIONAL, INTENT(in) :: lzero
2703	REAL(wp),OPTIONAL, INTENT(in) :: pval
2704
2705	CALL bound_exch_generic ( ib3=b,nhalo=nhalo,nhexch=nhexch, &
2706	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2707	cd_type=cd_type, lfill=lfill, pval=pval, &
2708	isgn=isgn, lzero=lzero )
2709
2710	END SUBROUTINE bound_exch3i
2711
2712
2713	SUBROUTINE lbc_exch2( pt2d, cd_type, psgn, cd_mpp, pval, lzero )
2714	USE par_oce, ONLY: wp, jpreci
2715	USE lib_mpp, ONLY : ctl_stop
2716	IMPLICIT none
2717	!!----------------------------------------------------------------------
2718	!! * routine mpp_lnk_2d *
2719	!!
2720	!! ** Purpose : Message passing management for 2d array
2721	!!
2722	!! ** Method : Use bound_exch_generic to update halos on neighbouring
2723	!! processes.
2724	!!
2725	!!----------------------------------------------------------------------
2726	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
2727	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
2728	! ! = T , U , V , F , W and I points
2729	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
2730	! ! = 1. , the sign is kept
2731	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
2732	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
2733	LOGICAL, OPTIONAL , INTENT(in ) :: lzero ! Whether to zero halos on closed boundaries
2734
2735	! Locals
2736	LOGICAL :: lfill
2737
2738	lfill = .FALSE.
2739	IF(PRESENT(cd_mpp))THEN
2740	lfill = .TRUE.
2741	END IF
2742
2743	CALL bound_exch_generic( b2=pt2d,nhalo=jpreci,nhexch=jpreci, &
2744	comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
2745	cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), &
2746	lzero=lzero )
2747
2748	END SUBROUTINE lbc_exch2
2749
2750
2751	SUBROUTINE lbc_exch3( ptab3d, cd_type, psgn, cd_mpp, pval, lzero )
2752	USE par_oce, ONLY: wp, jpreci
2753	USE lib_mpp, ONLY : ctl_stop
2754	IMPLICIT none
2755	!!----------------------------------------------------------------------
2756	!!----------------------------------------------------------------------
2757	!FTRANS ptab3d :I :I :z
2758	REAL(wp), INTENT(inout) :: ptab3d(:,:,:)
2759	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
2760	! ! = T , U , V , F , W points
2761	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
2762	! ! = 1. , the sign is kept
2763	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
2764	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
2765	LOGICAL, OPTIONAL , INTENT(in ) :: lzero ! Whether to zero halos on closed boundaries
2766	! Locals
2767	LOGICAL :: lfill
2768
2769	lfill = .FALSE.
2770	IF(PRESENT(cd_mpp))THEN
2771	lfill = .TRUE.
2772	END IF
2773
2774	CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci, &
2775	comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
2776	cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), &
2777	lzero=lzero )
2778
2779	END SUBROUTINE lbc_exch3
2780
2781	! ****************************************************************************
2782
2783	SUBROUTINE exchs_generic_list (list, nfields)
2784
2785	! **************************************************************************
2786	! Send boundary data elements to adjacent sub-domains.
2787	!
2788	! handle int output Exchange handle.
2789	! comm1 int input Send in direction comm1.
2790	! comm2 int input Send in direction comm2.
2791	! comm3 int input Send in direction comm3.
2792	! comm4 int input Send in direction comm4.
2793	! cd_type char input Nature of array grid-points
2794	! = T , U , V , F , W points
2795	! = S : T-point, north fold treatment?
2796	! = G : F-point, north fold treatment?
2797	! lfill logical input Whether to simply fill
2798	! overlap region or apply b.c.'s
2799	!
2800	! Mike Ashworth, CCLRC, March 2005.
2801	! Andrew Porter, STFC, January 2008
2802	! **************************************************************************
2803	USE par_oce, ONLY: wp, jpreci, jprecj, jpni
2804	USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, &
2805	IminusJminus, IplusJminus, IminusJplus, &
2806	nsend, nxsend, nysend, nxsendp,nysendp,nzsendp, &
2807	nsendp, &
2808	destination,dirsend, dirrecv, &
2809	isrcsendp,jsrcsendp, idesrecvp, jdesrecvp, &
2810	nrecv, &
2811	nxrecvp,nyrecvp,nzrecvp, nrecvp, nrecvp2d, &
2812	source, iesub, jesub, &
2813	MaxCommDir, MaxComm, cyclic_bc, &
2814	nrecvp, npatchsend, npatchrecv
2815	USE lib_mpp, ONLY: ctl_stop
2816	#if defined key_mpp_mpi
2817	USE lib_mpp, ONLY: mpi_comm_opa
2818	#endif
2819	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
2820	USE dom_oce, ONLY: narea
2821	#endif
2822	IMPLICIT none
2823
2824	! Subroutine arguments.
2825	TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
2826	INTEGER, INTENT(in) :: nfields
2827
2828	! Local variables.
2829
2830	LOGICAL :: enabled(0:MaxCommDir, maxExchItems)
2831	INTEGER :: ides, ierr, irecv, isend, &
2832	isrc, jdes, jsrc, tag, tag_orig, &
2833	ibeg, iend, jbeg, jend
2834	INTEGER :: i, j, k, ic, ifield, ipatch ! Loop counters
2835	! No. of array elements packed
2836	INTEGER :: npacked
2837	INTEGER :: handle
2838	#if defined key_mpp_mpi
2839	INTEGER :: status(MPI_status_size)
2840	INTEGER :: astatus(MPI_status_size,MaxComm)
2841	#endif
2842	INTEGER :: r2dcount, r3dcount, i2dcount, i3dcount
2843	! Indices into int and real copy buffers
2844	INTEGER :: istart, rstart
2845	! Max no. of points to send/recv (for alloc'ing buffers)
2846	INTEGER :: maxrecvpts, maxsendpts
2847	LOGICAL, SAVE :: first_time = .TRUE.
2848	LOGICAL :: have_real_field, have_int_field
2849	! Required size of buffer for current send
2850	INTEGER :: newSize
2851	! The current size (in array elements) of the send buffer
2852	INTEGER, SAVE :: sendIBuffSize = 0
2853	INTEGER, SAVE :: sendBuffSize = 0
2854	#if defined key_z_first
2855	INTEGER, PARAMETER :: index_z = 1
2856	#else
2857	INTEGER, PARAMETER :: index_z = 3
2858	#endif
2859	!!--------------------------------------------------------------------
2860
2861	#if ! defined key_mpp_rkpart
2862	RETURN
2863	#endif
2864
2865	!CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat)
2866
2867	! Allocate a communications tag/handle and a flags array.
2868
2869	handle = get_exch_handle()
2870	tag_orig = exch_tag(handle)
2871
2872	have_real_field = .FALSE.
2873	have_int_field = .FALSE.
2874
2875	! Set enabled flags according to the field details.
2876	DO ifield = 1, nfields, 1
2877
2878	! Check halo width is in range.
2879	IF ( list(ifield)%halo_width.GT.jpreci ) THEN
2880	CALL ctl_stop('STOP', &
2881	'exchs_generic_list: halo width greater than maximum')
2882	RETURN
2883	ENDIF
2884
2885	enabled(Iplus, ifield ) = .FALSE.
2886	enabled(Jplus, ifield ) = .FALSE.
2887	enabled(Iminus, ifield) = .FALSE.
2888	enabled(Jminus, ifield) = .FALSE.
2889	enabled(list(ifield)%dirn(1), ifield) = list(ifield)%dirn(1).GT.0
2890	enabled(list(ifield)%dirn(2), ifield) = list(ifield)%dirn(2).GT.0
2891	enabled(list(ifield)%dirn(3), ifield) = list(ifield)%dirn(3).GT.0
2892	enabled(list(ifield)%dirn(4), ifield) = list(ifield)%dirn(4).GT.0
2893
2894	! Set diagonal communications according to the non-diagonal flags.
2895
2896	enabled(IplusJplus, ifield ) = enabled(Iplus, ifield ).AND.enabled(Jplus, ifield )
2897	enabled(IminusJminus,ifield ) = enabled(Iminus, ifield ).AND.enabled(Jminus, ifield )
2898	enabled(IplusJminus, ifield ) = enabled(Iplus, ifield ).AND.enabled(Jminus, ifield )
2899	enabled(IminusJplus, ifield ) = enabled(Iminus, ifield ).AND.enabled(Jplus, ifield )
2900
2901	have_real_field = have_real_field .OR. &
2902	( ASSOCIATED(list(ifield)%r2dptr) .OR. &
2903	ASSOCIATED(list(ifield)%r3dptr) )
2904
2905	have_int_field = have_int_field .OR. &
2906	( ASSOCIATED(list(ifield)%i2dptr) .OR. &
2907	ASSOCIATED(list(ifield)%i3dptr) )
2908
2909	END DO ! Loop over fields
2910
2911	! Main communications loop.
2912	#if defined key_mpp_mpi
2913
2914	ierr = 0
2915	maxrecvpts = MAXVAL(nrecvp(1:nrecv,1))
2916	maxsendpts = MAXVAL(nsendp(1:nsend,1))
2917	!WRITE(*,"('maxrecvpts = ',I4,' maxsendpts = ',I4)") maxrecvpts, maxsendpts
2918
2919	IF( have_real_field )THEN
2920
2921	ALLOCATE(recvBuff(maxrecvpts*nfields,nrecv),stat=ierr)
2922	!WRITE(*,"('Allocated ',I7,' reals for recv buff')") &
2923	! jpkdtamaxrecvptsnfields
2924	!!$ IF(.NOT. ALLOCATED(sendBuff))THEN
2925	!!$ ! Only allocate the sendBuff once
2926	!!$ ALLOCATE(recvBuff(jpkdtamaxrecvptsnfields,nrecv), &
2927	!!$ sendBuff(jpkdtamaxsendptsnfields,nsend),stat=ierr)
2928	!!$ WRITE(,"('Allocated ',I7,' reals for recv buff')") jpkdtamaxrecvpts*nfields
2929	!!$ WRITE(,"('Allocated ',I7,' reals for send buff')") jpkdtamaxsendpts*nfields
2930	!!$ WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)"), nfields, jpkdta
2931	!!$ ELSE
2932	!!$ ALLOCATE(recvBuff(jpkdtamaxrecvptsnfields,nrecv),stat=ierr)
2933	!!$ END IF
2934	END IF
2935
2936	IF( have_int_field .AND. (ierr == 0) )THEN
2937
2938	ALLOCATE(recvIBuff(maxrecvpts*nfields,nrecv),stat=ierr)
2939	!WRITE(*,"('Allocated ',I7,' ints for recv buff')") &
2940	! jpkdtamaxrecvptsnfields
2941
2942	!!$ IF(.NOT. ALLOCATED(sendIBuff))THEN
2943	!!$ ALLOCATE(recvIBuff(jpkdtamaxrecvptsnfields,nrecv), &
2944	!!$ sendIBuff(jpkdtamaxsendptsnfields,nsend),stat=ierr)
2945	!!$ ELSE
2946	!!$ ALLOCATE(recvIBuff(jpkdtamaxrecvptsnfields,nrecv),stat=ierr)
2947	!!$ END IF
2948	END IF
2949
2950	IF (ierr .ne. 0) THEN
2951	WRITE(,) 'ARPDBG: failed to allocate recv buf'
2952	CALL ctl_stop('STOP','exchs_generic_list: unable to allocate recv buffs')
2953	END IF
2954
2955	! Initiate receives in case posting them first improves
2956	! performance.
2957
2958	exch_flags(handle,1:nrecv,indexr) = MPI_REQUEST_NULL
2959
2960	DO irecv=1, nrecv, 1
2961
2962	r2dcount = 0
2963	r3dcount = 0
2964	i2dcount = 0
2965	i3dcount = 0
2966
2967	IF( source(irecv).GE.0 .AND. &
2968	( (nrecvp(irecv,1) > 0) .OR. (nrecvp2d(irecv,1) > 0) ) ) THEN
2969
2970	! This loop is to allow for different fields to have different
2971	! direction requirements (possibly unecessary)
2972	DO ifield=1,nfields,1
2973
2974	IF ( enabled(dirrecv(irecv), ifield) ) THEN
2975	IF( ASSOCIATED(list(ifield)%r2dptr) )THEN
2976	r2dcount = r2dcount + nrecvp2d(irecv,1)
2977	ELSE IF( ASSOCIATED(list(ifield)%i2dptr) )THEN
2978	i2dcount = i2dcount + nrecvp2d(irecv,1)
2979	ELSE IF( ASSOCIATED(list(ifield)%r3dptr) )THEN
2980	! Allow for varying size of third dimension
2981	r3dcount = r3dcount + nrecvp(irecv,1)
2982	ELSE IF( ASSOCIATED(list(ifield)%i3dptr) )THEN
2983	! Allow for varying size of third dimension
2984	i3dcount = i3dcount + nrecvp(irecv,1)
2985	END IF
2986	END IF
2987
2988	END DO
2989
2990	tag = tag_orig + dirrecv(irecv)
2991
2992	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
2993	WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") &
2994	narea-1,tag ,source(irecv), nrecvp(irecv,1)
2995	#endif
2996
2997	IF ( r2dcount > 0 .OR. r3dcount > 0 ) THEN
2998	CALL MPI_irecv (recvBuff(1,irecv),(r2dcount+r3dcount), &
2999	MPI_DOUBLE_PRECISION, source(irecv), tag, mpi_comm_opa, &
3000	exch_flags(handle,irecv,indexr), ierr)
3001	END IF
3002	IF ( i2dcount > 0 .OR. i3dcount > 0 ) THEN
3003	CALL MPI_irecv (recvIBuff(1,irecv),(i2dcount+i3dcount), &
3004	MPI_INTEGER, source(irecv),tag, mpi_comm_opa, &
3005	exch_flags(handle,irecv,indexr),ierr)
3006	END IF
3007
3008	!!$#if defined DEBUG_COMMS
3009	!!$ WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' opp dirn = ',I1,' src = ',I3,' tag = ',I4,' flag = ',I3)") &
3010	!!$ narea-1,handle,dirrecv(irecv), &
3011	!!$ opp_dirn(dirrecv(irecv)),source(irecv), &
3012	!!$ tag, exch_flags(handle,irecv,indexr)
3013	!!$#endif
3014
3015	END IF
3016
3017	ENDDO ! Loop over receives
3018
3019
3020	! Check that all sends from previous call have completed before
3021	! we continue and modify the send buffers
3022	IF (.not. first_time) THEN
3023
3024	CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr)
3025	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3026
3027	ELSE
3028	first_time = .FALSE.
3029	END IF ! .not. first_time
3030
3031	! Now allocate/reallocate SEND buffers
3032
3033	ierr = 0
3034	newSize = maxsendpts*nfields
3035	IF( have_real_field .AND. newSize > sendBuffSize)THEN
3036	sendBuffSize=newSize
3037	IF(ALLOCATED(sendBuff))DEALLOCATE(sendBuff)
3038	ALLOCATE(sendBuff(sendBuffSize,nsend),stat=ierr)
3039
3040	!WRITE(*,"('Allocated ',I7,' reals for send buff')") sendBuffSize
3041	!WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)") nfields, jpkdta
3042	END IF
3043
3044	IF( have_int_field .AND. newSize > sendIBuffSize)THEN
3045	sendIBuffSize = newSize
3046	IF(ALLOCATED(sendIBuff))DEALLOCATE(sendIBuff)
3047	ALLOCATE(sendIBuff(sendIBuffSize,nsend),stat=ierr)
3048	END IF
3049
3050	IF (ierr .ne. 0) THEN
3051	CALL ctl_stop('STOP','exchs_generic_list: unable to allocate send buff')
3052	END IF
3053
3054	! Send all messages in the communications list.
3055
3056	exch_flags(handle,1:nsend,indexs) = MPI_REQUEST_NULL
3057
3058	DO isend=1, nsend, 1
3059
3060	rstart = 1
3061	istart = 1
3062	r2dcount = 0
3063	r3dcount = 0
3064	i2dcount = 0
3065	i3dcount = 0
3066
3067	IF ( destination(isend).GE.0 .AND. nxsend(isend).GT.0 ) THEN
3068
3069	! Loop over the fields for which we are going to exchange halos
3070	! and pack the data to send into a buffer
3071	DO ifield=1, nfields, 1
3072
3073	IF( enabled(dirsend(isend), ifield) )THEN
3074
3075	tag = tag_orig + dirsend(isend)
3076
3077	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3078	!!$ WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3079	!!$ narea-1, handle, tag, destination(isend),nsendp(isend,1)*XXX,dirsend(isend)
3080	!!$#endif
3081
3082	! Copy the data into the send buffer and send it. The
3083	! performance of this copy matters!
3084
3085	IF ( ASSOCIATED(list(ifield)%r2dptr) )THEN
3086
3087	ic = rstart - 1
3088
3089	pack_patches2r: DO ipatch=1, npatchsend(isend,1), 1
3090
3091	ibeg = isrcsendp(ipatch,isend,1)
3092	iend = ibeg + nxsendp(ipatch,isend,1)-1
3093	jbeg = jsrcsendp(ipatch,isend,1)
3094	jend = jbeg + nysendp(ipatch,isend,1)-1
3095
3096	DO j=jbeg, jend, 1
3097	DO i=ibeg, iend, 1
3098	ic = ic + 1
3099	sendBuff(ic, isend) = list(ifield)%r2dptr(i,j)
3100	END DO
3101	END DO
3102
3103	npacked = nxsendp(ipatch,isend,1) * &
3104	nysendp(ipatch,isend,1)
3105	rstart = rstart + npacked
3106	r2dcount = r2dcount + npacked
3107
3108	END DO pack_patches2r
3109
3110	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3111
3112	ic = istart - 1
3113
3114	pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1
3115
3116	jbeg = jsrcsendp(ipatch,isend,1)
3117	ibeg = isrcsendp(ipatch,isend,1)
3118	jend = jbeg + nysendp(ipatch,isend,1)-1
3119	iend = ibeg + nxsendp(ipatch,isend,1)-1
3120
3121	DO j=jbeg, jend, 1
3122	DO i=ibeg, iend, 1
3123	ic = ic + 1
3124	sendIBuff(ic,isend) = list(ifield)%i2dptr(i,j)
3125	END DO
3126	END DO
3127
3128	npacked = nxsendp(ipatch,isend,1) * &
3129	nysendp(ipatch,isend,1)
3130	istart = istart + npacked
3131	i2dcount = i2dcount + npacked
3132
3133	END DO pack_patches2i
3134
3135	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) )THEN
3136
3137	ic = rstart - 1
3138
3139	pack_patches3r: DO ipatch=1, npatchsend(isend,1), 1
3140
3141	! WRITE(*,"('Field = ',I2,' patch = ',I2,' ic = ',I4)") &
3142	! ifield, ipatch, ic
3143	jbeg = jsrcsendp(ipatch,isend,1)
3144	ibeg = isrcsendp(ipatch,isend,1)
3145	jend = jbeg + nysendp(ipatch,isend,1)-1
3146	iend = ibeg + nxsendp(ipatch,isend,1)-1
3147
3148	#if defined key_z_first
3149	DO j=jbeg, jend, 1
3150	DO i=ibeg, iend, 1
3151	!DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
3152	DO k=1, nzsendp(ipatch,isend,1), 1
3153	#else
3154	!DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
3155	DO k=1, nzsendp(ipatch,isend,1), 1
3156	DO j=jbeg, jend, 1
3157	DO i=ibeg, iend, 1
3158	#endif
3159	ic = ic + 1
3160	sendBuff(ic, isend) = list(ifield)%r3dptr(i,j,k)
3161	END DO
3162	END DO
3163	END DO
3164
3165	npacked = nxsendp(ipatch,isend,1) * &
3166	nysendp(ipatch,isend,1) * &
3167	nzsendp(ipatch,isend,1)
3168	rstart = rstart + npacked
3169	r3dcount = r3dcount + npacked
3170
3171	END DO pack_patches3r
3172
3173	ELSEIF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3174
3175	ic = istart - 1
3176
3177	pack_patches3i: DO ipatch = 1, npatchsend(isend, 1), 1
3178
3179	jbeg = jsrcsendp(ipatch,isend,1)
3180	ibeg = isrcsendp(ipatch,isend,1)
3181	jend = jbeg + nysendp(ipatch,isend,1)-1
3182	iend = ibeg + nxsendp(ipatch,isend,1)-1
3183
3184	#if defined key_z_first
3185	DO j=jbeg, jend, 1
3186	DO i=ibeg, iend, 1
3187	!DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
3188	DO k=1, nzsendp(ipatch,isend,1), 1
3189	#else
3190	!DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
3191	DO k=1, nzsendp(ipatch,isend,1), 1
3192	DO j=jbeg, jend, 1
3193	DO i=ibeg, iend, 1
3194	#endif
3195	ic = ic + 1
3196	sendIBuff(ic, isend) = list(ifield)%i3dptr(i,j,k)
3197	END DO
3198	END DO
3199	END DO
3200
3201	npacked = nxsendp(ipatch,isend,1)* &
3202	nysendp(ipatch,isend,1)* &
3203	nzsendp(ipatch,isend,1)
3204	istart = istart + npacked
3205	i3dcount = i3dcount + npacked
3206	END DO pack_patches3i
3207
3208	ENDIF
3209
3210	#if defined DEBUG_COMMS
3211	WRITE (*,FMT="(I4,': Isend to ',I3,' has flag ',I3)") &
3212	narea-1, destination(isend), exch_flags(handle,isend,indexs)
3213	#endif
3214
3215	END IF ! Direction enabled for this field
3216
3217	END DO ! Loop over fields
3218
3219	! Now do the send(s) for all fields
3220	IF(r2dcount > 0 .OR. r3dcount > 0 )THEN
3221	CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount), &
3222	MPI_DOUBLE_PRECISION, &
3223	destination(isend),tag,mpi_comm_opa, &
3224	exch_flags(handle,isend,indexs),ierr)
3225	END IF
3226	IF(i2dcount > 0 .OR. i3dcount > 0 )THEN
3227	CALL MPI_Isend(sendIBuff(1,isend),(i2dcount+i3dcount), &
3228	MPI_INTEGER, destination(isend),tag, &
3229	mpi_comm_opa, exch_flags(handle,isend,indexs),&
3230	ierr)
3231	END IF
3232
3233	ENDIF ! direction is enabled and have something to send
3234
3235	ENDDO ! Loop over sends
3236
3237	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3238	WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3239	#endif
3240
3241	! Wait on the receives that were posted earlier
3242
3243	! Copy just the set of flags we're interested in for passing to MPI_waitany
3244	exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3245
3246	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3247	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3248
3249	DO WHILE(irecv .ne. MPI_UNDEFINED)
3250
3251	istart = 1
3252	rstart = 1
3253
3254	DO ifield = 1, nfields, 1
3255
3256	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3257
3258	! Copy received data back into array
3259	ic = rstart - 1
3260	unpack_patches2r: DO ipatch=1, npatchrecv(irecv,1), 1
3261
3262	jbeg = jdesrecvp(ipatch,irecv,1)
3263	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3264	ibeg = idesrecvp(ipatch,irecv,1)
3265	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3266
3267	DO j=jbeg, jend, 1
3268	DO i=ibeg, iend, 1
3269
3270	ic = ic + 1
3271	list(ifield)%r2dptr(i,j) = recvBuff(ic,irecv)
3272	END DO
3273	END DO
3274
3275	END DO unpack_patches2r
3276
3277	! Increment starting index for next field data in buffer
3278	rstart = ic + 1 !rstart + nrecvp(irecv,1)
3279
3280	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3281
3282	! Copy received data back into array
3283	ic = istart - 1
3284	unpack_patches2i: DO ipatch = 1, npatchrecv(irecv,1), 1
3285
3286	jbeg = jdesrecvp(ipatch,irecv,1)
3287	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3288	ibeg = idesrecvp(ipatch,irecv,1)
3289	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3290
3291	DO j=jbeg, jend, 1
3292	DO i=ibeg, iend, 1
3293	ic = ic + 1
3294	list(ifield)%i2dptr(i,j) = recvIBuff(ic,irecv)
3295	END DO
3296	END DO
3297	END DO unpack_patches2i
3298
3299	! Increment starting index for next field data in buffer
3300	istart = ic + 1 !istart + nrecvp(irecv,1)
3301
3302	ELSE IF (ASSOCIATED(list(ifield)%r3dptr) ) THEN
3303
3304	ic = rstart - 1
3305	unpack_patches3r: DO ipatch=1,npatchrecv(irecv,1)
3306
3307	jbeg = jdesrecvp(ipatch,irecv,1)
3308	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3309	ibeg = idesrecvp(ipatch,irecv,1)
3310	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3311	#if defined key_z_first
3312	DO j=jbeg, jend, 1
3313	DO i=ibeg, iend, 1
3314	DO k=1, nzrecvp(ipatch,irecv,1), 1
3315	#else
3316	DO k=1, nzrecvp(ipatch,irecv,1), 1
3317	DO j=jbeg, jend, 1
3318	DO i=ibeg, iend, 1
3319	#endif
3320	ic = ic + 1
3321	list(ifield)%r3dptr(i,j,k) = recvBuff(ic,irecv)
3322	END DO
3323	END DO
3324	END DO
3325	END DO unpack_patches3r
3326
3327	! Increment starting index for next field data in buffer
3328	rstart = ic + 1 ! rstart + nrecvp(irecv,1) !*SIZE(list(ifield)%r3dptr,index_z)
3329
3330	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3331
3332	ic = istart - 1
3333	unpack_patches3i: DO ipatch=1,npatchrecv(irecv,1)
3334
3335	jbeg = jdesrecvp(ipatch,irecv,1)
3336	jend = jbeg+nyrecvp(ipatch,irecv,1)-1
3337	ibeg = idesrecvp(ipatch,irecv,1)
3338	iend = ibeg+nxrecvp(ipatch,irecv,1)-1
3339	#if defined key_z_first
3340	DO j=jbeg, jend, 1
3341	DO i=ibeg, iend, 1
3342	DO k=1,nzrecvp(ipatch,irecv,1),1
3343	#else
3344	DO k=1,nzrecvp(ipatch,irecv,1),1
3345	DO j=jbeg, jend, 1
3346	DO i=ibeg, iend, 1
3347	#endif
3348	ic = ic + 1
3349	list(ifield)%i3dptr(i,j,k) = recvIBuff(ic,irecv)
3350	END DO
3351	END DO
3352	END DO
3353	END DO unpack_patches3i
3354
3355	! Increment starting index for next field data in buffer
3356	istart = ic + 1 !istart + nrecvp(irecv,1) !*SIZE(list(ifield)%i3dptr,index_z)
3357
3358	END IF
3359
3360	END DO ! Loop over fields
3361
3362	! Wait for the next received message (if any)
3363	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3364	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3365
3366	END DO ! while irecv != MPI_UNDEFINED
3367
3368	! All receives done and unpacked - can deallocate the recv buffer now
3369	IF(ALLOCATED(recvBuff))DEALLOCATE(recvBuff)
3370	IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
3371
3372	#endif /* key_mpp_mpi */
3373
3374	! Periodic boundary condition using internal copy.
3375	! This is performed after all data has been received so that we can
3376	! also copy boundary points and avoid some diagonal communication.
3377	! Since this is just a copy we don't worry about the 'patches' of
3378	! wet points here.
3379
3380	! ARPDBG - fairly certain this code is not yet correct :-(
3381
3382	IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
3383
3384	DO ifield=1,nfields,1
3385
3386	IF ( enabled(Iplus,ifield) ) THEN
3387
3388	DO j=1,jesub+list(ifield)%halo_width
3389
3390	DO i=1,list(ifield)%halo_width
3391
3392	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3393	list(ifield)%r2dptr(iesub+i,j) = list(ifield)%r2dptr(i,j)
3394	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3395	list(ifield)%i2dptr(iesub+i,j) = list(ifield)%i2dptr(i,j)
3396	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN
3397	DO k=1,SIZE(list(ifield)%r3dptr, index_z)
3398	list(ifield)%r3dptr(iesub+i,j,k) = list(ifield)%r3dptr(i,j,k)
3399	ENDDO
3400	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3401	DO k=1,SIZE(list(ifield)%i3dptr, index_z)
3402	list(ifield)%i3dptr(iesub+i,j,k) = list(ifield)%i3dptr(i,j,k)
3403	ENDDO
3404	END IF
3405	ENDDO
3406	ENDDO
3407	END IF
3408
3409	IF ( enabled(Iminus,ifield) ) THEN
3410	!ARPDBG DO j=1,jesub,1
3411	DO j=1,jesub+list(ifield)%halo_width
3412	DO i=1, list(ifield)%halo_width
3413	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3414	!ARPDBG b2(i,j) = b2(iesub-i+1,j)
3415	list(ifield)%r2dptr(i,j) = list(ifield)%r2dptr(iesub-i+1,j)
3416	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3417	!ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
3418	list(ifield)%i2dptr(i,j) = list(ifield)%i2dptr(iesub-i+1,j)
3419	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN
3420
3421	DO k=1,SIZE(list(ifield)%r3dptr,index_z),1
3422	!ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
3423	list(ifield)%r3dptr(i,j,k) = list(ifield)%r3dptr(iesub-i+1,j,k)
3424	ENDDO
3425	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3426	DO k=1,SIZE(list(ifield)%i3dptr,index_z), 1
3427	!ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
3428	list(ifield)%i3dptr(i,j,k) = list(ifield)%i3dptr(iesub-i+1,j,k)
3429	END DO
3430	END IF
3431	END DO
3432	END DO
3433	END IF
3434
3435	END DO ! Loop over fields
3436	ENDIF ! cyclic_bc .AND. jpni==1
3437
3438	! Copy just the set of flags we're interested in for passing to
3439	! MPI_waitall next time around
3440	exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
3441
3442	! Free the exchange communications handle.
3443	CALL free_exch_handle(handle)
3444
3445	!CALL prof_region_end(ARPEXCHS_LIST, iprofStat)
3446
3447	END SUBROUTINE exchs_generic_list
3448
3449	! *********************************************************************
3450
3451	SUBROUTINE exchs_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
3452	handle, comm1, comm2, comm3, comm4, &
3453	cd_type, lfill)
3454
3455	! *******************************************************************
3456	! Send boundary data elements to adjacent sub-domains.
3457
3458	! b2(:,:) real input 2D real*8 local array.
3459	! ib2(:,:) int input 2D integer local array.
3460	! b3(:,:,:) real input 3D real*8 local array.
3461	! ib3(:,:,:) int input 3D integer local array.
3462	! nhalo int input Width of halo.
3463	! nhexch int input Number of halo
3464	! rows/cols to exchange.
3465	! handle int output Exchange handle.
3466	! comm1 int input Send in direction comm1.
3467	! comm2 int input Send in direction comm2.
3468	! comm3 int input Send in direction comm3.
3469	! comm4 int input Send in direction comm4.
3470	! cd_type char input Nature of array grid-points
3471	! = T , U , V , F , W points
3472	! = S : T-point, north fold treatment?
3473	! = G : F-point, north fold treatment?
3474	! lfill logical input Whether to simply fill
3475	! overlap region or apply b.c.'s
3476	!
3477	! Mike Ashworth, CCLRC, March 2005.
3478	! Andrew Porter, STFC, January 2008
3479	! *******************************************************************
3480	USE par_oce, ONLY: wp, jpreci, jprecj, jpni, jpkdta
3481	USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, &
3482	IminusJminus, IplusJminus, IminusJplus, &
3483	nrecv, nsend, nrecvp, nsendp, &
3484	nrecvp2d, nsendp2d, nxsend, nysend, &
3485	destination,dirsend, dirrecv, &
3486	isrcsend, jsrcsend, idesrecv, jdesrecv, &
3487	isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, &
3488	nxrecv,source, iesub, jesub, &
3489	MaxCommDir, MaxComm, idessend, jdessend, &
3490	nxsendp, nysendp, nzsendp, &
3491	nxrecvp, nyrecvp, nzrecvp, &
3492	npatchsend, npatchrecv, cyclic_bc
3493	USE lib_mpp, ONLY: ctl_stop
3494	#if defined key_mpp_mpi
3495	USE lib_mpp, ONLY: mpi_comm_opa
3496	#endif
3497	USE dom_oce, ONLY: narea
3498	USE in_out_manager, ONLY: numout
3499	IMPLICIT none
3500
3501	! Subroutine arguments.
3502	INTEGER, INTENT(in) :: nhalo,nhexch
3503	INTEGER, INTENT(out) :: handle
3504
3505	!FTRANS b3 :I :I :z
3506	!FTRANS ib3 :I :I :z
3507	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:) :: b2
3508	INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:) :: ib2
3509	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: b3
3510	INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: ib3
3511
3512	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
3513	CHARACTER(len=1), INTENT(in) :: cd_type
3514	LOGICAL, INTENT(in) :: lfill
3515
3516	! Local variables.
3517
3518	LOGICAL :: enabled(0:MaxCommDir)
3519	INTEGER :: ierr, irecv, ircvdt, isend, isnddt, &
3520	isrc, jsrc, kdim1, & ! ides, jdes, nxr, nyr, &
3521	nxs, nys, tag, tag_orig
3522	INTEGER :: maxrecvpts, maxsendpts ! Max no. of grid points involved in
3523	! any one halo exchange
3524	INTEGER :: i, j, k, ic, ipatch ! Loop counters
3525	INTEGER :: istart, iend, jstart, jend
3526	INTEGER :: index ! To hold index returned from MPI_waitany
3527	INTEGER, DIMENSION(3) :: isubsizes, istarts ! isizes
3528	#if defined key_mpp_mpi
3529	INTEGER :: status(MPI_status_size)
3530	INTEGER :: astatus(MPI_status_size,MaxComm)
3531	#endif
3532	LOGICAL, SAVE :: first_time = .TRUE.
3533	#if defined key_z_first
3534	INTEGER, PARAMETER :: index_z = 1
3535	#else
3536	INTEGER, PARAMETER :: index_z = 3
3537	#endif
3538	!!--------------------------------------------------------------------
3539
3540	#if ! defined key_mpp_rkpart
3541	RETURN
3542	#endif
3543
3544	!CALL prof_region_begin(ARPEXCHS_GENERIC, "Exchs_indiv", iprofStat)
3545	!CALL timing_start('exchs_generic')
3546
3547	ierr = 0
3548
3549	! Check nhexch is in range.
3550
3551	IF ( nhexch.GT.jpreci ) THEN
3552	CALL ctl_stop('STOP','exchs: halo width greater than maximum')
3553	ENDIF
3554
3555	! Allocate a communications tag/handle and a flags array.
3556
3557	handle = get_exch_handle()
3558	tag_orig = exch_tag(handle)
3559
3560	! Set enabled flags according to the subroutine arguments.
3561
3562	enabled(Iplus ) = .FALSE.
3563	enabled(Jplus ) = .FALSE.
3564	enabled(Iminus) = .FALSE.
3565	enabled(Jminus) = .FALSE.
3566	enabled(comm1) = comm1.GT.0
3567	enabled(comm2) = comm2.GT.0
3568	enabled(comm3) = comm3.GT.0
3569	enabled(comm4) = comm4.GT.0
3570
3571	! Set diagonal communications according to the non-diagonal flags.
3572
3573	enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
3574	enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
3575	enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
3576	enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
3577
3578	! Main communications loop.
3579	#if defined key_mpp_mpi
3580
3581	maxrecvpts = MAXVAL(nrecvp(1:nrecv,1))
3582	maxsendpts = MAXVAL(nsendp(1:nsend,1))
3583
3584	IF(PRESENT(b2) .OR. PRESENT(b3))THEN
3585	IF(.NOT. ALLOCATED(sendBuff))THEN
3586	! Only allocate the sendBuff once
3587	ALLOCATE(recvBuff(maxrecvpts,nrecv), &
3588	sendBuff(maxsendpts,nsend),stat=ierr)
3589	ELSE
3590	ALLOCATE(recvBuff(maxrecvpts,nrecv),stat=ierr)
3591	END IF
3592	ELSE IF(PRESENT(ib2) .OR. PRESENT(ib3))THEN
3593	IF(.NOT. ALLOCATED(sendIBuff))THEN
3594	ALLOCATE(recvIBuff(maxrecvpts,nrecv), &
3595	sendIBuff(maxsendpts,nsend),stat=ierr)
3596	ELSE
3597	ALLOCATE(recvIBuff(maxrecvpts,nrecv),stat=ierr)
3598	END IF
3599	END IF
3600
3601	IF (ierr .ne. 0) THEN
3602	CALL ctl_stop('STOP','exchs_generic: unable to allocate send/recvBuffs')
3603	END IF
3604
3605	! Initiate receives in case posting them first improves
3606	! performance.
3607
3608	DO irecv=1,nrecv
3609
3610	IF ( enabled(dirrecv(irecv)) .AND. &
3611	source(irecv).GE.0 .AND. nxrecv(irecv).GT.0 ) THEN
3612
3613	tag = tag_orig + dirrecv(irecv)
3614
3615	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3616	WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") narea-1,tag ,source(irecv), nrecvp(irecv,1)
3617	#endif
3618	! ARPDBG - nrecvp second rank is for multiple halo widths but
3619	! that isn't used
3620	IF ( PRESENT(b2) ) THEN
3621	CALL MPI_irecv (recvBuff(1,irecv),nrecvp2d(irecv,1), &
3622	MPI_DOUBLE_PRECISION, source(irecv), &
3623	tag, mpi_comm_opa, &
3624	exch_flags(handle,irecv,indexr), ierr)
3625	ELSEIF ( PRESENT(ib2) ) THEN
3626	CALL MPI_irecv (recvIBuff(1,irecv),nrecvp2d(irecv,1), &
3627	MPI_INTEGER, source(irecv), &
3628	tag, mpi_comm_opa, &
3629	exch_flags(handle,irecv,indexr),ierr)
3630	ELSEIF ( PRESENT(b3) ) THEN
3631	CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1), &
3632	MPI_DOUBLE_PRECISION, source(irecv), &
3633	tag, mpi_comm_opa, &
3634	exch_flags(handle,irecv,indexr),ierr)
3635	ELSEIF ( PRESENT(ib3) ) THEN
3636	CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1), &
3637	MPI_INTEGER, source(irecv), &
3638	tag, mpi_comm_opa, &
3639	exch_flags(handle,irecv,indexr),ierr)
3640	ENDIF
3641	! No point checking for MPI errors because default MPI error handler
3642	! aborts run without returning control to calling program.
3643	!IF ( ierr.NE.0 ) THEN
3644	! WRITE (numout,*) 'ARPDBG - irecv hit error'
3645	! CALL flush(numout)
3646	! CALL MPI_abort(mpi_comm_opa,1,ierr)
3647	!END IF
3648
3649	#if defined DEBUG_COMMS
3650	WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' src = ',I3,' tag = ',I4,' npoints = ',I6)") &
3651	narea-1,handle,dirrecv(irecv), &
3652	source(irecv), tag, nrecvp(irecv,1)
3653	#endif
3654
3655	ELSE
3656	exch_flags(handle,irecv,indexr) = MPI_REQUEST_NULL
3657	END IF
3658
3659	ENDDO
3660
3661	IF (.not. first_time) THEN
3662
3663	! Check that all sends from previous call have completed before
3664	! we continue to modify the send buffers
3665	CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr)
3666	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3667
3668	ELSE
3669	first_time = .FALSE.
3670	END IF ! .not. first_time
3671
3672
3673	! Send all messages in the communications list.
3674
3675	! CALL timing_start('mpi_sends')
3676
3677	DO isend=1,nsend
3678
3679	IF ( enabled(dirsend(isend)) .AND. &
3680	destination(isend) >= 0 .AND. nxsend(isend) > 0 ) THEN
3681
3682	isrc = isrcsend(isend)
3683	jsrc = jsrcsend(isend)
3684	nxs = nxsend(isend)
3685	nys = nysend(isend)
3686
3687	tag = tag_orig + dirsend(isend)
3688
3689	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3690	IF(PRESENT(b3))THEN
3691	WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3692	narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend)
3693	ELSE IF(PRESENT(b2))THEN
3694	WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3695	narea-1, handle, tag, destination(isend),nsendp2d(isend,1),dirsend(isend)
3696	END IF
3697	#endif
3698
3699	! Copy the data into the send buffer and send it...
3700
3701	IF ( PRESENT(b2) )THEN
3702
3703	! CALL timing_start('2dr_pack')
3704	ic = 0
3705	pack_patches2r: DO ipatch=1,npatchsend(isend,1)
3706	istart = isrcsendp(ipatch,isend,1)
3707	iend = istart+nxsendp(ipatch,isend,1)-1
3708	jstart = jsrcsendp(ipatch,isend,1)
3709	jend = jstart+nysendp(ipatch,isend,1)-1
3710
3711	DO j=jstart, jend, 1
3712	DO i=istart, iend, 1
3713	ic = ic + 1
3714	sendBuff(ic,isend) = b2(i,j)
3715	END DO
3716	END DO
3717
3718	!!$ ! For 'stupid' compiler that refuses to do a memcpy for above
3719	!!$ CALL do_real8_copy( nxsendp(patch,isend,1)*nysendp(patch,isend,1), &
3720	!!$ b2(istart,jstart), &
3721	!!$ sendBuff(ic,isend) )
3722	!!$ ic = ic + nxsendp(patch,isend,1)*nysendp(patch,isend,1)
3723
3724	END DO pack_patches2r
3725
3726	! CALL timing_stop('2dr_pack')
3727
3728	CALL MPI_Isend(sendBuff(1,isend),ic,MPI_DOUBLE_PRECISION, &
3729	destination(isend),tag,mpi_comm_opa, &
3730	exch_flags(handle,isend,indexs),ierr)
3731
3732	ELSEIF ( PRESENT(ib2) ) THEN
3733
3734	ic = 0
3735	pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1
3736	jstart = jsrcsendp(ipatch,isend,1)
3737	istart = isrcsendp(ipatch,isend,1)
3738	jend = jstart+nysendp(ipatch,isend,1)-1
3739	iend = istart+nxsendp(ipatch,isend,1)-1
3740
3741	DO j=jstart, jend, 1
3742	DO i=istart, iend, 1
3743	ic = ic + 1
3744	sendIBuff(ic,isend) = ib2(i,j)
3745	END DO
3746	END DO
3747	END DO pack_patches2i
3748
3749	CALL MPI_Isend(sendIBuff(1,isend),ic, MPI_INTEGER, &
3750	destination(isend),tag,mpi_comm_opa,&
3751	exch_flags(handle,isend,indexs),ierr)
3752
3753	ELSEIF ( PRESENT(b3) )THEN
3754
3755	! CALL timing_start('3dr_pack')
3756	ic = 0
3757	pack_patches3r: DO ipatch=1,npatchsend(isend,1)
3758
3759	IF(nzsendp(ipatch,isend,1) > SIZE(b3,3))THEN
3760	CALL MPI_Abort(mpi_comm_opa,-1,ierr)
3761	CALL ctl_stop('STOP','exchs_generic: b3 has wrong z dimension')
3762	END IF
3763
3764	jstart = jsrcsendp(ipatch,isend,1)
3765	istart = isrcsendp(ipatch,isend,1)
3766	jend = jstart+nysendp(ipatch,isend,1)-1
3767	iend = istart+nxsendp(ipatch,isend,1)-1
3768	#if defined key_z_first
3769	DO j=jstart, jend, 1
3770	DO i=istart, iend, 1
3771	DO k=1,nzsendp(ipatch,isend,1),1
3772	#else
3773	DO k=1,nzsendp(ipatch,isend,1),1
3774	DO j=jstart, jend, 1
3775	DO i=istart, iend, 1
3776	#endif
3777	ic = ic + 1
3778	sendBuff(ic, isend) = b3(i,j,k)
3779	END DO
3780	END DO
3781	END DO
3782	END DO pack_patches3r
3783
3784	! CALL timing_stop('3dr_pack')
3785
3786	CALL MPI_Isend(sendBuff(1,isend),ic, &
3787	MPI_DOUBLE_PRECISION, &
3788	destination(isend), tag, mpi_comm_opa, &
3789	exch_flags(handle,isend,indexs),ierr)
3790
3791	#if defined DEBUG_COMMS
3792	WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &
3793	narea-1, npatchsend(isend,1),ic, &
3794	destination(isend)
3795	#endif
3796
3797	ELSEIF ( PRESENT(ib3) ) THEN
3798
3799	ic = 0
3800	pack_patches3i: DO ipatch=1,npatchsend(isend,1)
3801	jstart = jsrcsendp(ipatch,isend,1) !+nhalo
3802	istart = isrcsendp(ipatch,isend,1) !+nhalo
3803	jend = jstart+nysendp(ipatch,isend,1)-1
3804	iend = istart+nxsendp(ipatch,isend,1)-1
3805	#if defined key_z_first
3806	DO j=jstart, jend, 1
3807	DO i=istart, iend, 1
3808	DO k=1,nzsendp(ipatch,isend,1),1
3809	#else
3810	DO k=1,nzsendp(ipatch,isend,1),1
3811	DO j=jstart, jend, 1
3812	DO i=istart, iend, 1
3813	#endif
3814	ic = ic + 1
3815	sendIBuff(ic, isend) = ib3(i,j,k)
3816	END DO
3817	END DO
3818	END DO
3819	END DO pack_patches3i
3820
3821	CALL MPI_Isend(sendIBuff(1,isend),ic, &
3822	MPI_INTEGER, &
3823	destination(isend),tag,mpi_comm_opa, &
3824	exch_flags(handle,isend,indexs),ierr)
3825	ENDIF
3826
3827	!IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3828
3829	ELSE
3830
3831	exch_flags(handle,isend,indexs) = MPI_REQUEST_NULL
3832
3833	ENDIF ! direction is enabled and have something to send
3834
3835	ENDDO ! Loop over sends
3836
3837	! CALL timing_stop('mpi_sends')
3838
3839	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3840	WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3841	#endif
3842
3843	! Wait on the receives that were posted earlier
3844
3845	! CALL timing_start('mpi_recvs')
3846
3847	! Copy just the set of flags we're interested in for passing
3848	! to MPI_waitany
3849	exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3850
3851	#if defined DEBUG_COMMS
3852	WRITE(*,"(I3,': Doing waitany: nrecv =',I3,' handle = ',I3)") &
3853	narea-1, nrecv,handle
3854	#endif
3855
3856	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3857	IF ( ierr .NE. MPI_SUCCESS ) THEN
3858
3859	IF(ierr .EQ. MPI_ERR_REQUEST)THEN
3860	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_REQUEST')") narea-1
3861	ELSE IF(ierr .EQ. MPI_ERR_ARG)THEN
3862	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_ARG')") narea-1
3863	ELSE
3864	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1
3865	END IF
3866	CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error')
3867	END IF
3868
3869	DO WHILE(irecv .ne. MPI_UNDEFINED)
3870
3871	IF ( PRESENT(b2) ) THEN
3872
3873	! CALL timing_start('2dr_unpack')
3874
3875	! Copy received data back into array
3876	ic = 0
3877	unpack_patches2r: DO ipatch=1,npatchrecv(irecv,nhexch)
3878
3879	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3880	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3881	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3882	iend = istart+nxrecvp(ipatch,irecv,1)-1
3883	DO j=jstart, jend, 1
3884	DO i=istart, iend, 1
3885	ic = ic + 1
3886	b2(i,j) = recvBuff(ic,irecv)
3887	END DO
3888	END DO
3889	END DO unpack_patches2r
3890
3891	! CALL timing_stop('2dr_unpack')
3892
3893	ELSE IF ( PRESENT(ib2) ) THEN
3894
3895	! Copy received data back into array
3896	ic = 0
3897	unpack_patches2i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3898
3899	jstart = jdesrecvp(ipatch,irecv,1)
3900	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3901	istart = idesrecvp(ipatch,irecv,1)
3902	iend = istart+nxrecvp(ipatch,irecv,1)-1
3903	DO j=jstart, jend, 1
3904	DO i=istart, iend, 1
3905	ic = ic + 1
3906	ib2(i,j) = recvIBuff(ic,irecv)
3907	END DO
3908	END DO
3909	END DO unpack_patches2i
3910
3911	ELSE IF (PRESENT(b3) ) THEN
3912
3913	! CALL timing_start('3dr_unpack')
3914	ic = 0
3915	unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch)
3916
3917	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3918	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3919	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3920	iend = istart+nxrecvp(ipatch,irecv,1)-1
3921
3922	IF(nzrecvp(ipatch,irecv,1) > SIZE(b3,3))THEN
3923	CALL MPI_Abort(mpi_comm_opa,-1,ierr)
3924	CALL ctl_stop('STOP', &
3925	'exchs_generic: wrong z dim for b3 in recv')
3926	END IF
3927
3928	#if defined key_z_first
3929	DO j=jstart, jend, 1
3930	DO i=istart, iend, 1
3931	DO k=1,nzrecvp(ipatch,irecv,1),1
3932	#else
3933	DO k=1,nzrecvp(ipatch,irecv,1),1
3934	DO j=jstart, jend, 1
3935	DO i=istart, iend, 1
3936	#endif
3937	ic = ic + 1
3938	b3(i,j,k) = recvBuff(ic,irecv)
3939	END DO
3940	#if defined key_z_first
3941	! ARPDBG - wipe anything below the ocean bottom
3942	DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3943	b3(i,j,k) = 0.0_wp
3944	END DO
3945	#endif
3946	END DO
3947	END DO
3948
3949	! ARPDBG - wipe anything below the ocean bottom
3950	#if ! defined key_z_first
3951	DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3952	DO j=jstart, jend, 1
3953	DO i=istart, iend, 1
3954	b3(i,j,k) = 0.0_wp
3955	END DO
3956	END DO
3957	END DO
3958	#endif
3959
3960	END DO unpack_patches3r
3961
3962	! CALL timing_stop('3dr_unpack')
3963
3964	ELSEIF ( PRESENT(ib3) ) THEN
3965
3966	ic = 0
3967	unpack_patches3i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3968
3969	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3970	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3971	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3972	iend = istart+nxrecvp(ipatch,irecv,1)-1
3973	#if defined key_z_first
3974	DO j=jstart, jend, 1
3975	DO i=istart, iend, 1
3976	DO k=1,nzrecvp(ipatch,irecv,1),1
3977	#else
3978	DO k=1,nzrecvp(ipatch,irecv,1),1
3979	DO j=jstart, jend, 1
3980	DO i=istart, iend, 1
3981	#endif
3982	ic = ic + 1
3983	ib3(i,j,k) = recvIBuff(ic,irecv)
3984	END DO
3985	END DO
3986	END DO
3987	END DO unpack_patches3i
3988
3989	END IF
3990
3991	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3992	!IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3993
3994	END DO ! while irecv != MPI_UNDEFINED
3995
3996	! CALL timing_stop('mpi_recvs')
3997
3998	! All receives done and unpacked so can deallocate the associated
3999	! buffers
4000	!IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)
4001	!IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
4002
4003	#if defined DEBUG_COMMS
4004	WRITE(*,"(I3,': Finished all ',I3,' receives for handle ',I3)") &
4005	narea-1, nrecv, handle
4006	#endif
4007
4008	#endif /* key_mpp_mpi */
4009
4010	! Periodic boundary condition using internal copy.
4011	! This is performed after all data has been received so that we can
4012	! also copy boundary points and avoid some diagonal communication.
4013	!
4014	! ARPDBG - performance issue: need to hoist IF block outside nested
4015	! loop!
4016	IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
4017
4018	! Find out the sizes of the arrays.
4019	kdim1 = 1
4020	IF ( PRESENT(b3) ) THEN
4021	kdim1 = SIZE(b3,dim=index_z)
4022	ELSEIF ( PRESENT(ib3) ) THEN
4023	kdim1 = SIZE(ib3,dim=index_z)
4024	ENDIF
4025
4026
4027	IF ( enabled(Iplus) ) THEN
4028	!ARPDBG DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4029	DO j=1,jesub+jpreci
4030	!ARPDBG DO i=nhexch,1,-1
4031	DO i=1,jpreci
4032	IF ( PRESENT(b2) ) THEN
4033	!ARPDBG b2(iesub-i+1,j) = b2(i,j)
4034	b2(iesub+i,j) = b2(i,j)
4035	ELSEIF ( PRESENT(ib2) ) THEN
4036	!ARPDBG ib2(iesub-i+1,j) = ib2(i,j)
4037	ib2(iesub+i,j) = ib2(i,j)
4038	ELSEIF ( PRESENT(b3) ) THEN
4039	! dir$ unroll
4040	DO k=1,kdim1
4041	!ARPDBG b3(k,iesub-i+1,j) = b3(k,i,j)
4042	b3(k,iesub+i,j) = b3(k,i,j)
4043	ENDDO
4044	ELSEIF ( PRESENT(ib3) ) THEN
4045	! dir$ unroll
4046	DO k=1,kdim1
4047	!ARPDBG ib3(k,iesub-i+1,j) = ib3(k,i,j)
4048	ib3(k,iesub+i,j) = ib3(k,i,j)
4049	ENDDO
4050	ENDIF
4051	ENDDO
4052	ENDDO
4053	ENDIF
4054
4055	IF ( enabled(Iminus) ) THEN
4056	!ARPDBG DO j=1,jesub,1
4057	DO j=1,jesub+jpreci
4058	DO i=1,jpreci
4059	IF ( PRESENT(b2) ) THEN
4060	!ARPDBG b2(i,j) = b2(iesub-i+1,j)
4061	b2(1-i,j) = b2(iesub-i+1,j)
4062	ELSEIF ( PRESENT(ib2) ) THEN
4063	!ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
4064	ib2(1-i,j) = ib2(iesub-i+1,j)
4065	ELSEIF ( PRESENT(b3) ) THEN
4066	! dir$ unroll
4067	DO k=1,kdim1
4068	!ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
4069	b3(1-i,j,k) = b3(iesub-i+1,j,k)
4070	ENDDO
4071	ELSEIF ( PRESENT(ib3) ) THEN
4072	! dir$ unroll
4073	DO k=1,kdim1
4074	!ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
4075	ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4076	ENDDO
4077	ENDIF
4078	ENDDO
4079	ENDDO
4080	ENDIF
4081
4082	ENDIF ! cyclic_bc .AND. jpni == 1
4083
4084	! Copy just the set of flags we're interested in for passing to
4085	! MPI_waitall next time around
4086	exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
4087
4088	! Free the exchange communications handle.
4089	CALL free_exch_handle(handle)
4090
4091	! All receives done so we can safely free the MPI receive buffers
4092	IF( ALLOCATED(recvBuff) ) DEALLOCATE(recvBuff)
4093	IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff)
4094
4095	! CALL timing_stop('exchs_generic')
4096	!CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat)
4097
4098	END SUBROUTINE exchs_generic
4099
4100	! ********************************************************************
4101
4102	!!$ SUBROUTINE exchr_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
4103	!!$ handle, comm1, comm2, comm3, comm4 )
4104	!!$
4105	!!$ ! ******************************************************************
4106	!!$
4107	!!$ ! Receive boundary data elements from adjacent sub-domains.
4108	!!$
4109	!!$ ! b2(1-nhalo:,1-nhalo:) real input 2D real*8 local array.
4110	!!$ ! ib2(1-nhalo:,1-nhalo:) int input 2D integer local array.
4111	!!$ ! b3(:,1-nhalo:,1-nhalo:) real input 3D real*8 local array.
4112	!!$ ! ib3(:,1-nhalo:,1-nhalo:) int input 3D integer local array.
4113	!!$ ! nhalo int input Width of halo.
4114	!!$ ! nhexch int input Number of halo
4115	!!$ ! rows/cols to exchange.
4116	!!$ ! handle int input Exchange handle.
4117	!!$ ! comm1 int input Send in direction comm1.
4118	!!$ ! comm2 int input Send in direction comm2.
4119	!!$ ! comm3 int input Send in direction comm3.
4120	!!$ ! comm4 int input Send in direction comm4.
4121	!!$
4122	!!$ ! Mike Ashworth, CCLRC, March 2005.
4123	!!$
4124	!!$ ! ******************************************************************
4125	!!$ USE mapcomm_mod, ONLY: iesub,jesub,MaxCommDir,Iplus,Jplus,Iminus, &
4126	!!$ Jminus, IplusJplus,IminusJminus,IplusJminus, &
4127	!!$ IminusJplus, nrecv, nxrecv,nyrecv, source, dirrecv, &
4128	!!$ idesrecv, jdesrecv, cyclic_bc, destination, &
4129	!!$ nsend, nxsend, dirsend
4130	!!$ !ARPDBG: do_exchanges below is debug only
4131	!!$ USE par_oce, ONLY: jpni, jpreci, wp, do_exchanges
4132	!!$ USE lib_mpp, ONLY: mpi_comm_opa
4133	!!$ USE dom_oce, ONLY: narea
4134	!!$#ifdef WITH_LIBHMD
4135	!!$ USE in_out_manager, ONLY: lwp
4136	!!$#endif
4137	!!$ IMPLICIT NONE
4138	!!$
4139	!!$ INTEGER :: status(MPI_status_size)
4140	!!$
4141	!!$ ! Subroutine arguments.
4142	!!$!xxFTRANS b3 :I :I :z
4143	!!$!xxFTRANS ib3 :I :I :z
4144	!!$ INTEGER, INTENT(In) :: nhalo,nhexch,handle
4145	!!$ REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:) :: b2
4146	!!$ INTEGER, INTENT(inout), OPTIONAL, DIMENSION(:,:) :: ib2
4147	!!$ REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: b3
4148	!!$ INTEGER, INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: ib3
4149	!!$ INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
4150	!!$
4151	!!$ ! Local variables.
4152	!!$
4153	!!$ LOGICAL :: enabled(0:MaxCommDir)
4154	!!$ INTEGER :: i, ides, ierr, irecv, isend, j, jdes, k, &
4155	!!$ kdim1, nxr, nyr
4156	!!$
4157	!!$#ifdef PARALLEL_STATS
4158	!!$ LOGICAL :: probe
4159	!!$ INTEGER :: nbpw
4160	!!$#endif
4161	!!$
4162	!!$ IF(.not. do_exchanges)THEN
4163	!!$ WRITE (,) 'ARPDBG: exchr_generic: do_exchanges is FALSE'
4164	!!$ RETURN ! ARPDBG
4165	!!$ END IF
4166	!!$
4167	!!$#ifdef PARALLEL_STATS
4168	!!$ IF ( PRESENT(b2) .OR. PRESENT(b3) ) THEN
4169	!!$ nbpw = 8
4170	!!$ ELSE
4171	!!$ nbpw = nbpi
4172	!!$ ENDIF
4173	!!$#endif
4174	!!$
4175	!!$ ! Find out the sizes of the arrays.
4176	!!$
4177	!!$ kdim1 = 1
4178	!!$ IF ( PRESENT(b3) ) THEN
4179	!!$!! DCSE_NEMO - bug here in original code?
4180	!!$! Code used to say kdim1 = SIZE(b3,dim=1) whereas ARP thinks it should
4181	!!$! have had dim=3. Ditto for ib3 below.
4182	!!$#if defined key_z_first
4183	!!$ kdim1 = SIZE(b3,dim=1)
4184	!!$#else
4185	!!$ kdim1 = SIZE(b3,dim=3)
4186	!!$#endif
4187	!!$! isizes(3) = kdim1
4188	!!$! isizes(2) = SIZE(b3,dim=2)
4189	!!$! isizes(1) = SIZE(b3,dim=1)
4190	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4191	!!$#if defined key_z_first
4192	!!$ kdim1 = SIZE(ib3,dim=1)
4193	!!$#else
4194	!!$ kdim1 = SIZE(ib3,dim=3)
4195	!!$#endif
4196	!!$! isizes(3) = kdim1
4197	!!$! isizes(2) = SIZE(ib3,dim=2)
4198	!!$! isizes(1) = SIZE(ib3,dim=1)
4199	!!$ ENDIF
4200	!!$
4201	!!$ ! Check nhexch is in range.
4202	!!$
4203	!!$ IF ( nhexch.GT.jpreci ) THEN
4204	!!$ STOP 'exchr: halo width greater than maximum'
4205	!!$ ENDIF
4206	!!$
4207	!!$ ! Set enabled flags according to the subroutine arguments.
4208	!!$
4209	!!$ enabled(Iplus ) = .FALSE.
4210	!!$ enabled(Jplus ) = .FALSE.
4211	!!$ enabled(Iminus) = .FALSE.
4212	!!$ enabled(Jminus) = .FALSE.
4213	!!$ enabled(comm1) = comm1.GT.0
4214	!!$ enabled(comm2) = comm2.GT.0
4215	!!$ enabled(comm3) = comm3.GT.0
4216	!!$ enabled(comm4) = comm4.GT.0
4217	!!$
4218	!!$ ! Set diagonal communications according to the non-diagonal flags.
4219	!!$
4220	!!$ enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
4221	!!$ enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
4222	!!$ enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
4223	!!$ enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
4224	!!$
4225	!!$ ! Main communications loop.
4226	!!$
4227	!!$ ! Receive all messages in the communications list.
4228	!!$
4229	!!$ DO irecv=1,nrecv
4230	!!$
4231	!!$ IF ( enabled(dirrecv(irecv)) .AND. source(irecv).GE.0 &
4232	!!$! .AND. nxrecv(irecv,nhexch).GT.0 ) THEN
4233	!!$ .AND. nxrecv(irecv).GT.0 ) THEN
4234	!!$
4235	!!$! ides = idesrecv(irecv,nhexch)
4236	!!$! jdes = jdesrecv(irecv,nhexch)
4237	!!$! nxr = nxrecv(irecv,nhexch)
4238	!!$! nyr = nyrecv(irecv,nhexch)
4239	!!$ ides = idesrecv(irecv)
4240	!!$ jdes = jdesrecv(irecv)
4241	!!$ nxr = nxrecv(irecv)
4242	!!$ nyr = nyrecv(irecv)
4243	!!$
4244	!!$ ! Wait on the receives that were actually posted in the send routine
4245	!!$
4246	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
4247	!!$ WRITE (*,FMT="(I4,': test for recv from ',I3,' data ',I3,' x ',I3,' to ',I3,I3)") narea-1,source(irecv),nxr,nyr,ides,jdes
4248	!!$ WRITE (*,FMT="(I4,': test flag = ',I3)") narea-1, &
4249	!!$ exch_flags(handle,irecv,indexr)
4250	!!$#endif
4251	!!$
4252	!!$#ifdef PARALLEL_STATS
4253	!!$ CALL MPI_test (exch_flags(handle,irecv,indexr),probe,status,ierr)
4254	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4255	!!$ IF ( .NOT.probe ) THEN
4256	!!$ nmwait = nmwait+1
4257	!!$ ENDIF
4258	!!$#endif /* PARALLEL_STATS */
4259	!!$ CALL MPI_wait (exch_flags(handle,irecv,indexr),status,ierr)
4260	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4261	!!$
4262	!!$#ifdef PARALLEL_STATS
4263	!!$ nmrecv = nmrecv + 1
4264	!!$ nbrecv = nbrecv + kdim1nbpwnxr*nyr
4265	!!$
4266	!!$#endif /* PARALLEL_STATS */
4267	!!$ ENDIF
4268	!!$
4269	!!$ ENDDO
4270	!!$
4271	!!$ ! Periodic boundary condition using internal copy.
4272	!!$ ! This is performed after all data has been received so that we can
4273	!!$ ! also copy boundary points and avoid some diagonal communication.
4274	!!$
4275	!!$ IF ( cyclic_bc .AND. jpni.EQ.1 ) THEN
4276	!!$
4277	!!$ IF ( enabled(Iplus) ) THEN
4278	!!$ !ARPDBG DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4279	!!$!ARPDBG - broken? Loop over j is used as 3rd index in 3D arrays
4280	!!$!ARPDBG but kdim1 is correctly(?) set to extent of first dimension
4281	!!$ DO j=1,jesub+jpreci
4282	!!$ !ARPDBG DO i=nhexch,1,-1
4283	!!$ DO i=1,jpreci
4284	!!$ IF ( PRESENT(b2) ) THEN
4285	!!$ !ARPDBG b2(iesub-i+1,j) = b2(i,j)
4286	!!$ b2(iesub+i,j) = b2(i,j)
4287	!!$ ELSEIF ( PRESENT(ib2) ) THEN
4288	!!$ !ARPDBG ib2(iesub-i+1,j) = ib2(i,j)
4289	!!$ ib2(iesub+i,j) = ib2(i,j)
4290	!!$ ELSEIF ( PRESENT(b3) ) THEN
4291	!!$ ! dir$ unroll
4292	!!$ DO k=1,kdim1
4293	!!$ !ARPDBG b3(k,iesub-i+1,j) = b3(k,i,j)
4294	!!$ b3(k,iesub+i,j) = b3(k,i,j)
4295	!!$ ENDDO
4296	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4297	!!$ ! dir$ unroll
4298	!!$ DO k=1,kdim1
4299	!!$ !ARPDBG ib3(k,iesub-i+1,j) = ib3(k,i,j)
4300	!!$ ib3(k,iesub+i,j) = ib3(k,i,j)
4301	!!$ ENDDO
4302	!!$ ENDIF
4303	!!$ ENDDO
4304	!!$ ENDDO
4305	!!$ ENDIF
4306	!!$
4307	!!$ IF ( enabled(Iminus) ) THEN
4308	!!$ !ARPDBG DO j=1,jesub,1
4309	!!$ DO j=1,jesub+jpreci
4310	!!$ DO i=1,jpreci
4311	!!$ IF ( PRESENT(b2) ) THEN
4312	!!$ !ARPDBG b2(i,j) = b2(iesub-i+1,j)
4313	!!$ b2(1-i,j) = b2(iesub-i+1,j)
4314	!!$ ELSEIF ( PRESENT(ib2) ) THEN
4315	!!$ !ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
4316	!!$ ib2(1-i,j) = ib2(iesub-i+1,j)
4317	!!$ ELSEIF ( PRESENT(b3) ) THEN
4318	!!$ ! dir$ unroll
4319	!!$ DO k=1,kdim1
4320	!!$ !ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
4321	!!$ b3(1-i,j,k) = b3(iesub-i+1,j,k)
4322	!!$ ENDDO
4323	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4324	!!$ ! dir$ unroll
4325	!!$ DO k=1,kdim1
4326	!!$ !ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
4327	!!$ ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4328	!!$ ENDDO
4329	!!$ ENDIF
4330	!!$ ENDDO
4331	!!$ ENDDO
4332	!!$ ENDIF
4333	!!$
4334	!!$ ENDIF
4335	!!$
4336	!!$ IF ( immed ) THEN
4337	!!$
4338	!!$ ! Check completion for immediate sends.
4339	!!$
4340	!!$ DO isend=1,nsend
4341	!!$
4342	!!$ IF (enabled(dirsend(isend)) .AND. &
4343	!!$ destination(isend).GE.0 .AND. nxsend(isend,nhexch).GT.0 ) THEN
4344	!!$
4345	!!$ CALL MPI_wait (exch_flags(handle,isend,indexs),status,ierr)
4346	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4347	!!$
4348	!!$ ENDIF
4349	!!$
4350	!!$ ENDDO
4351	!!$
4352	!!$ ENDIF
4353	!!$
4354	!!$ ! Free the exchange communications handle.
4355	!!$
4356	!!$ CALL free_exch_handle(handle)
4357	!!$
4358	!!$ END SUBROUTINE exchr_generic
4359
4360	!=======================================================================
4361
4362	SUBROUTINE mpp_lbc_north_list(list, nfields)
4363	USE par_oce, ONLY : jpni, jpi, jpj
4364	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
4365	nwidthmax
4366	USE mapcomm_mod, ONLY : pielb, piesub
4367	USE lib_mpp, ONLY : ctl_stop
4368	IMPLICIT none
4369	! Subroutine arguments.
4370	TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
4371	INTEGER, INTENT(in) :: nfields
4372
4373	!! * Local declarations
4374	INTEGER :: ijpj ! No. of rows to operate upon
4375	INTEGER :: ii, ji, jj, jk, jji, jjr, jr, jproc, klimit
4376	INTEGER :: ierr, ifield, ishifti, ishiftr
4377	INTEGER :: ildi,ilei,iilb
4378	INTEGER :: ij,ijt,iju, isgn
4379	INTEGER :: itaille
4380	!FTRANS ztab :I :I :z
4381	!FTRANS iztab :I :I :z
4382	!FTRANS znorthgloio :I :I :z :
4383	!FTRANS iznorthgloio :I :I :z :
4384	!FTRANS znorthloc :I :I :z
4385	!FTRANS iznorthloc :I :I :z
4386	INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: iztab
4387	INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: iznorthgloio
4388	INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: iznorthloc
4389	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ztab
4390	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio
4391	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthloc
4392	REAL(wp) :: psgn ! control of the sign change
4393	LOGICAL :: field_is_real, fields_all_real, fields_all_int
4394	LOGICAL :: fields_all_3d, fields_all_2d
4395	!!----------------------------------------------------------------------
4396
4397	CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat)
4398
4399	#if defined key_mpp_mpi
4400
4401	! If we get into this routine it's because : North fold condition and mpp
4402	! with more than one PE across i : we deal only with the North condition
4403
4404	! Set no. of rows from a module parameter that is also used in exchtestmod
4405	! and mpp_ini_north
4406	ijpj = num_nfold_rows
4407
4408	! Allocate work-space arrays
4409	IF(.not. ALLOCATED(ztab))THEN
4410
4411	ALLOCATE(ztab(jpiglo,maxExchItems*ijpj,jpkorig), &
4412	iztab(jpiglo,maxExchItems*ijpj,jpkorig), &
4413	znorthgloio(nwidthmax,maxExchItems*ijpj,jpkorig,jpni), &
4414	znorthloc(nwidthmax,maxExchItems*ijpj,jpkorig), &
4415	iznorthgloio(nwidthmax,maxExchItems*ijpj,jpkorig,jpni), &
4416	iznorthloc(nwidthmax,maxExchItems*ijpj,jpkorig), &
4417	STAT=ierr)
4418	IF(ierr .ne. 0)THEN
4419	CALL ctl_stop('STOP','mpp_lbc_north_list: memory allocation failed')
4420	RETURN
4421	END IF
4422	END IF
4423
4424	! put the last ijpj jlines of each real field into znorthloc
4425	! znorthloc(:,:,:) = 0_wp ! because of padding for nwidthmax
4426	! iznorthloc(:,:,:) = 0
4427	ishiftr = 0
4428	ishifti = 0
4429	fields_all_real = .TRUE.
4430	fields_all_int = .TRUE.
4431	fields_all_3d = .TRUE.
4432	fields_all_2d = .TRUE.
4433
4434	CALL prof_region_begin(NORTHLISTGATHER, "NorthListGather", iprofStat)
4435
4436	DO ifield=1,nfields,1
4437
4438	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
4439	DO ij = 1, ijpj, 1
4440	jj = nlcj - ijpj + ij
4441	znorthloc(nldi:nlei,ij+ishiftr,1) = &
4442	list(ifield)%r2dptr(nldi:nlei,jj)
4443	END DO
4444
4445	ishiftr = ishiftr + ijpj
4446	fields_all_int = .FALSE.
4447	fields_all_3d = .FALSE.
4448	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
4449
4450	#if defined key_z_first
4451	DO ij = 1, ijpj, 1
4452	jj = nlcj - ijpj + ij
4453	DO ii = nldi, nlei, 1
4454	DO jk = 1, jpk
4455	#else
4456	DO jk = 1, jpk
4457	DO ij = 1, ijpj, 1
4458	jj = nlcj - ijpj + ij
4459	DO ii = nldi, nlei, 1
4460	#endif
4461	znorthloc(ii,ij+ishiftr,jk) = &
4462	list(ifield)%r3dptr(ii,jj,jk)
4463	END DO
4464	END DO
4465	END DO
4466
4467	ishiftr = ishiftr + ijpj
4468	fields_all_int = .FALSE.
4469	fields_all_2d = .FALSE.
4470	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
4471
4472	DO ij = 1, ijpj, 1
4473	jj = nlcj - ijpj + ij
4474	iznorthloc(nldi:nlei,ij+ishifti,1) = &
4475	list(ifield)%i2dptr(nldi:nlei,jj)
4476	END DO
4477
4478	ishifti = ishifti + ijpj
4479	fields_all_real = .FALSE.
4480	fields_all_3d = .FALSE.
4481	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
4482
4483	#if defined key_z_first
4484	DO ij = 1, ijpj, 1
4485	jj = nlcj - ijpj + ij
4486	DO ii = nldi, nlei, 1
4487	DO jk = 1, jpk
4488	#else
4489	DO jk = 1, jpk
4490	DO ij = 1, ijpj, 1
4491	jj = nlcj - ijpj + ij
4492	DO ii = nldi, nlei, 1
4493	#endif
4494	iznorthloc(ii,ij+ishifti,jk) = &
4495	list(ifield)%i3dptr(ii,jj,jk)
4496	END DO
4497	END DO
4498	END DO
4499
4500	ishifti = ishifti + ijpj
4501	fields_all_real = .FALSE.
4502	fields_all_2d = .FALSE.
4503	END IF
4504
4505	END DO ! loop over fields
4506
4507	klimit = 1
4508	IF(.not. fields_all_2d)klimit = jpk
4509
4510	IF (npolj /= 0 ) THEN
4511	IF(.NOT. fields_all_int )THEN
4512	! Build znorthgloio on proc 0 of ncomm_north
4513	!znorthgloio(:,:,:,:) = 0_wp
4514	itaille=nwidthmaxishiftrklimit
4515	#if defined key_mpp_mpi
4516	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, &
4517	znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
4518	0, ncomm_north, ierr)
4519	#endif
4520	END IF
4521	IF(.NOT. fields_all_real )THEN
4522	! Build iznorthgloio on proc 0 of ncomm_north
4523	!iznorthgloio(:,:,:,:) = 0
4524	itaille=nwidthmaxishiftiklimit
4525	#if defined key_mpp_mpi
4526	CALL MPI_GATHER(iznorthloc,itaille,MPI_INTEGER, &
4527	iznorthgloio,itaille,MPI_INTEGER,&
4528	0, ncomm_north, ierr)
4529	#endif
4530	END IF
4531	ENDIF
4532
4533	CALL prof_region_end(NORTHLISTGATHER, iprofStat)
4534
4535	CALL prof_region_begin(ARPNORTHAPPLYSYMM, "NorthListApplySymm", iprofStat)
4536
4537	IF (narea == north_root+1 ) THEN
4538	! recover the global north array for every field
4539	! ztab(:,:,:) = 0_wp
4540	! iztab(:,:,:) = 0_wp
4541
4542	IF( .NOT. fields_all_int )THEN
4543
4544	DO jr = 1, ndim_rank_north
4545	jproc = nrank_north(jr) + 1
4546	ildi = nldit (jproc)
4547	ilei = nleit (jproc)
4548	iilb = pielb(jproc)
4549	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:jpk) = &
4550	znorthgloio(ildi:ilei,1:ishiftr,1:jpk,jr)
4551	END DO
4552	END IF
4553	IF( .NOT. fields_all_real )THEN
4554
4555	DO jr = 1, ndim_rank_north
4556	jproc = nrank_north(jr) + 1
4557	ildi = nldit (jproc)
4558	ilei = nleit (jproc)
4559	iilb = pielb(jproc)
4560	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:jpk) = &
4561	iznorthgloio(ildi:ilei,1:ishifti,1:jpk,jr)
4562	END DO
4563	END IF
4564
4565	! Horizontal slab
4566	! ===============
4567
4568	jji = ijpj
4569	jjr = ijpj
4570
4571	! 2. North-Fold boundary conditions
4572	! ----------------------------------
4573
4574	SELECT CASE ( npolj )
4575
4576	CASE ( 3, 4 ) ! * North fold T-point pivot
4577
4578	DO ifield=1, nfields, 1
4579
4580	! Set-up stuff dependent on whether this field is real or integer
4581	field_is_real = .FALSE.
4582	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4583	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
4584
4585	isgn = list(ifield)%isgn
4586	psgn = REAL(isgn, wp)
4587
4588	! Set up stuff dependent on whether this field is 2- or 3-dimensional
4589	IF(fields_all_3d)THEN
4590	klimit=jpk
4591	ELSE IF(fields_all_2d)THEN
4592	klimit = 1
4593	ELSE
4594	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4595	ASSOCIATED(list(ifield)%i3dptr) )THEN
4596	klimit=jpk
4597	ELSE
4598	klimit = 1
4599	END IF
4600	END IF
4601
4602	IF(field_is_real)THEN
4603	ztab( 1 , jjr, 1:klimit) = 0._wp
4604	ztab(jpiglo, jjr, 1:klimit) = 0._wp
4605	ELSE
4606	iztab( 1 , jji, 1:klimit) = 0
4607	iztab(jpiglo, jji, 1:klimit) = 0
4608	END IF
4609
4610	SELECT CASE ( list(ifield)%grid )
4611
4612	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
4613
4614	IF(field_is_real)THEN
4615	#if defined key_z_first
4616	DO ji = 2, jpiglo/2
4617	ijt = jpiglo-ji+2
4618	DO jk = 1,klimit,1
4619	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4620	END DO
4621	END DO
4622	DO ji = jpiglo/2+1, jpiglo
4623	ijt = jpiglo-ji+2
4624	DO jk = 1,klimit,1
4625	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4626	ztab(ji,jjr, jk) = psgn * ztab(ijt,jjr-2,jk)
4627	END DO
4628	END DO
4629	#else
4630	DO jk = 1,klimit,1
4631	DO ji = 2, jpiglo/2
4632	ijt = jpiglo-ji+2
4633	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4634	END DO
4635	DO ji = jpiglo/2+1, jpiglo
4636	ijt = jpiglo-ji+2
4637	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4638	ztab(ji,jjr, jk) = psgn * ztab(ijt,jjr-2,jk)
4639	END DO
4640	END DO
4641	#endif
4642	ELSE
4643	#if defined key_z_first
4644	DO ji = 2, jpiglo
4645	ijt = jpiglo-ji+2
4646	DO jk=1,klimit,1
4647	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4648	END DO
4649	END DO
4650	DO ji = jpiglo/2+1, jpiglo
4651	ijt = jpiglo-ji+2
4652	DO jk=1,klimit,1
4653	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4654	END DO
4655	END DO
4656	#else
4657	DO jk=1,klimit,1
4658	DO ji = 2, jpiglo
4659	ijt = jpiglo-ji+2
4660	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4661	END DO
4662	DO ji = jpiglo/2+1, jpiglo
4663	ijt = jpiglo-ji+2
4664	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4665	END DO
4666	END DO
4667	#endif
4668	END IF
4669
4670	CASE ( 'U' ) ! U-point
4671
4672	IF(field_is_real)THEN
4673	#if defined key_z_first
4674	DO ji = 1, jpiglo-1
4675	iju = jpiglo-ji+1
4676	DO jk=1,klimit,1
4677	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk)
4678	END DO
4679	END DO
4680	DO ji = jpiglo/2, jpiglo-1
4681	iju = jpiglo-ji+1
4682	DO jk=1,klimit,1
4683	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4684	END DO
4685	END DO
4686	#else
4687	DO jk=1,klimit,1
4688	DO ji = 1, jpiglo-1
4689	iju = jpiglo-ji+1
4690	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk)
4691	END DO
4692	DO ji = jpiglo/2, jpiglo-1
4693	iju = jpiglo-ji+1
4694	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4695	END DO
4696	END DO
4697	#endif
4698	ELSE
4699	#if defined key_z_first
4700	DO ji = 1, jpiglo-1
4701	iju = jpiglo-ji+1
4702	DO jk=1,klimit,1
4703	iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk)
4704	END DO
4705	END DO
4706	DO ji = jpiglo/2, jpiglo-1
4707	iju = jpiglo-ji+1
4708	DO jk=1,klimit,1
4709	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
4710	END DO
4711	END DO
4712	#else
4713	DO jk=1,klimit,1
4714	DO ji = 1, jpiglo-1
4715	iju = jpiglo-ji+1
4716	iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk)
4717	END DO
4718	DO ji = jpiglo/2, jpiglo-1
4719	iju = jpiglo-ji+1
4720	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
4721	END DO
4722	END DO
4723	#endif
4724	END IF
4725
4726	CASE ( 'V' ) ! V-point
4727
4728	IF(field_is_real)THEN
4729	#if defined key_z_first
4730	DO ji = 2, jpiglo
4731	ijt = jpiglo-ji+2
4732	DO jk=1,klimit,1
4733	#else
4734	DO jk=1,klimit,1
4735	DO ji = 2, jpiglo
4736	ijt = jpiglo-ji+2
4737	#endif
4738	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-2,jk)
4739	ztab(ji,jjr ,jk) = psgn * ztab(ijt,jjr-3,jk)
4740	END DO
4741	END DO
4742	ELSE
4743	#if defined key_z_first
4744	DO ji = 2, jpiglo
4745	ijt = jpiglo-ji+2
4746	DO jk=1,klimit,1
4747	#else
4748	DO jk=1,klimit,1
4749	DO ji = 2, jpiglo
4750	ijt = jpiglo-ji+2
4751	#endif
4752	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-2,jk)
4753	iztab(ji,jji ,jk) = isgn * iztab(ijt,jji-3,jk)
4754	END DO
4755	END DO
4756	END IF
4757
4758	CASE ( 'F' , 'G' ) ! F-point
4759
4760	IF(field_is_real)THEN
4761	#if defined key_z_first
4762	DO ji = 1, jpiglo-1
4763	iju = jpiglo-ji+1
4764	DO jk=1,klimit,1
4765	#else
4766	DO jk=1,klimit,1
4767	DO ji = 1, jpiglo-1
4768	iju = jpiglo-ji+1
4769	#endif
4770	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-2,jk)
4771	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-3,jk)
4772	END DO
4773	END DO
4774	ELSE
4775	#if defined key_z_first
4776	DO ji = 1, jpiglo-1
4777	iju = jpiglo-ji+1
4778	DO jk=1,klimit,1
4779	#else
4780	DO jk=1,klimit,1
4781	DO ji = 1, jpiglo-1
4782	iju = jpiglo-ji+1
4783	#endif
4784	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-2,jk)
4785	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-3,jk)
4786	END DO
4787	END DO
4788	END IF
4789
4790	CASE ( 'I' ) ! ice U-V point
4791
4792	IF(field_is_real)THEN
4793	#if defined key_z_first
4794	DO jk=1,klimit,1
4795	ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk)
4796	END DO
4797	DO ji = 3, jpiglo
4798	iju = jpiglo - ji + 3
4799	DO jk=1,klimit,1
4800	#else
4801	DO jk=1,klimit,1
4802	ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk)
4803	DO ji = 3, jpiglo
4804	iju = jpiglo - ji + 3
4805	#endif
4806	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk)
4807	END DO
4808	END DO
4809	ELSE
4810	#if defined key_z_first
4811	DO jk=1,klimit,1
4812	iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk)
4813	END DO
4814	DO ji = 3, jpiglo
4815	iju = jpiglo - ji + 3
4816	DO jk=1,klimit,1
4817	#else
4818	DO jk=1,klimit,1
4819	iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk)
4820	DO ji = 3, jpiglo
4821	iju = jpiglo - ji + 3
4822	#endif
4823	iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk)
4824	END DO
4825	END DO
4826	END IF
4827
4828	END SELECT
4829
4830	! Move to the next set of ijpj rows corresponding to the next field
4831	jjr = jjr + ijpj
4832	jji = jji + ijpj
4833
4834	END DO ! Loop over fields
4835
4836	CASE ( 5, 6 ) ! * North fold F-point pivot
4837
4838	DO ifield=1, nfields, 1
4839
4840	! Set-up stuff dependent on whether this field is real or integer
4841	field_is_real = .FALSE.
4842	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4843	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
4844
4845	isgn = list(ifield)%isgn
4846	psgn=REAL(isgn, wp)
4847
4848	! Set up stuff dependent on whether this field is 2- or 3-dimensional
4849	IF(fields_all_3d)THEN
4850	klimit=jpk
4851	ELSE IF(fields_all_2d)THEN
4852	klimit = 1
4853	ELSE
4854	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4855	ASSOCIATED(list(ifield)%i3dptr) )THEN
4856	klimit=jpk
4857	ELSE
4858	klimit = 1
4859	END IF
4860	END IF
4861
4862	IF(field_is_real)THEN
4863	DO jk = 1, klimit, 1
4864	ztab( 1 ,jjr,jk) = 0.0_wp
4865	ztab(jpiglo,jjr,jk) = 0.0_wp
4866	END DO
4867	ELSE
4868	DO jk = 1, klimit, 1
4869	iztab( 1 ,jji,jk) = 0
4870	iztab(jpiglo,jji,jk) = 0
4871	END DO
4872	END IF
4873
4874	SELECT CASE ( list(ifield)%grid )
4875
4876	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
4877
4878	IF(field_is_real)THEN
4879	#if defined key_z_first
4880	DO ji = 1, jpiglo
4881	ijt = jpiglo-ji+1
4882	DO jk = 1,klimit,1
4883	#else
4884	DO jk = 1,klimit,1
4885	DO ji = 1, jpiglo
4886	ijt = jpiglo-ji+1
4887	#endif
4888	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-1,jk)
4889	END DO
4890	END DO
4891	ELSE
4892	#if defined key_z_first
4893	DO ji = 1, jpiglo
4894	ijt = jpiglo-ji+1
4895	DO jk=1,klimit,1
4896	#else
4897	DO jk=1,klimit,1
4898	DO ji = 1, jpiglo
4899	ijt = jpiglo-ji+1
4900	#endif
4901	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-1,jk)
4902	END DO
4903	END DO
4904	END IF
4905
4906	CASE ( 'U' ) ! U-point
4907
4908	IF(field_is_real)THEN
4909	#if defined key_z_first
4910	DO ji = 1, jpiglo-1
4911	iju = jpiglo-ji
4912	DO jk=1,klimit,1
4913	#else
4914	DO jk=1,klimit,1
4915	DO ji = 1, jpiglo-1
4916	iju = jpiglo-ji
4917	#endif
4918	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk)
4919	END DO
4920	END DO
4921	ELSE
4922	#if defined key_z_first
4923	DO ji = 1, jpiglo-1
4924	iju = jpiglo-ji
4925	DO jk=1,klimit,1
4926	#else
4927	DO jk=1,klimit,1
4928	DO ji = 1, jpiglo-1
4929	iju = jpiglo-ji
4930	#endif
4931	iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk)
4932	END DO
4933	END DO
4934	END IF
4935
4936	CASE ( 'V' ) ! V-point
4937	IF(field_is_real)THEN
4938	#if defined key_z_first
4939	DO ji = 1, jpiglo
4940	ijt = jpiglo-ji+1
4941	DO jk=1,klimit,1
4942	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4943	END DO
4944	END DO
4945	DO ji = jpiglo/2+1, jpiglo
4946	ijt = jpiglo-ji+1
4947	DO jk=1,klimit,1
4948	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4949	END DO
4950	END DO
4951	#else
4952	DO jk=1,klimit,1
4953	DO ji = 1, jpiglo
4954	ijt = jpiglo-ji+1
4955	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4956	END DO
4957	DO ji = jpiglo/2+1, jpiglo
4958	ijt = jpiglo-ji+1
4959	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4960	END DO
4961	END DO
4962	#endif
4963	ELSE
4964	#if defined key_z_first
4965	DO ji = 1, jpiglo
4966	ijt = jpiglo-ji+1
4967	DO jk=1,klimit,1
4968	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4969	END DO
4970	END DO
4971	DO ji = jpiglo/2+1, jpiglo
4972	ijt = jpiglo-ji+1
4973	DO jk=1,klimit,1
4974	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4975	END DO
4976	END DO
4977	#else
4978	DO jk=1,klimit,1
4979	DO ji = 1, jpiglo
4980	ijt = jpiglo-ji+1
4981	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4982	END DO
4983	DO ji = jpiglo/2+1, jpiglo
4984	ijt = jpiglo-ji+1
4985	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4986	END DO
4987	END DO
4988	#endif
4989	END IF
4990
4991	CASE ( 'F' , 'G' ) ! F-point
4992
4993	IF(field_is_real)THEN
4994	#if defined key_z_first
4995
4996	DO ji = 1, jpiglo-1
4997	iju = jpiglo-ji
4998	DO jk=1,klimit,1
4999	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-2,jk)
5000	END DO
5001	END DO
5002	DO ji = jpiglo/2+1, jpiglo-1
5003	iju = jpiglo-ji
5004	DO jk=1,klimit,1
5005	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
5006	END DO
5007	END DO
5008	#else
5009	DO jk=1,klimit,1
5010	DO ji = 1, jpiglo-1
5011	iju = jpiglo-ji
5012	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-2,jk)
5013	END DO
5014	DO ji = jpiglo/2+1, jpiglo-1
5015	iju = jpiglo-ji
5016	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
5017	END DO
5018	END DO
5019	#endif
5020	ELSE
5021	#if defined key_z_first
5022	DO ji = 1, jpiglo-1
5023	iju = jpiglo-ji
5024	DO jk=1,klimit,1
5025	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-2,jk)
5026	END DO
5027	END DO
5028	DO ji = jpiglo/2+1, jpiglo-1
5029	iju = jpiglo-ji
5030	DO jk=1,klimit,1
5031	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
5032	END DO
5033	END DO
5034	#else
5035	DO jk=1,klimit,1
5036	DO ji = 1, jpiglo-1
5037	iju = jpiglo-ji
5038	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-2,jk)
5039	END DO
5040	DO ji = jpiglo/2+1, jpiglo-1
5041	iju = jpiglo-ji
5042	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
5043	END DO
5044	END DO
5045	#endif
5046	END IF
5047
5048	CASE ( 'I' ) ! ice U-V point
5049
5050	IF(field_is_real)THEN
5051	#if defined key_z_first
5052	DO jk=1,klimit,1
5053	ztab( 2 ,jjr,jk) = 0._wp
5054	END DO
5055	DO ji = 2 , jpiglo-1
5056	ijt = jpiglo - ji + 2
5057	DO jk=1,klimit,1
5058	ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + &
5059	psgn * ztab(ijt,jjr-1,jk) )
5060	END DO
5061	END DO
5062	#else
5063	DO jk=1,klimit,1
5064	ztab( 2 ,jjr,jk) = 0._wp
5065	DO ji = 2 , jpiglo-1
5066	ijt = jpiglo - ji + 2
5067	ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + &
5068	psgn * ztab(ijt,jjr-1,jk) )
5069	END DO
5070	END DO
5071	#endif
5072	ELSE
5073	#if defined key_z_first
5074	DO jk=1,klimit,1
5075	iztab( 2 ,jji,jk) = 0
5076	END DO
5077	DO ji = 2 , jpiglo-1
5078	ijt = jpiglo - ji + 2
5079	DO jk=1,klimit,1
5080	iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + &
5081	isgn * iztab(ijt,jji-1,jk) )
5082	END DO
5083	END DO
5084	#else
5085	DO jk=1,klimit,1
5086	iztab( 2 ,jji,jk) = 0
5087	DO ji = 2 , jpiglo-1
5088	ijt = jpiglo - ji + 2
5089	iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + &
5090	isgn * iztab(ijt,jji-1,jk) )
5091	END DO
5092	END DO
5093	#endif
5094	END IF
5095
5096	END SELECT
5097
5098	! Move to the next set of ijpj rows corresponding to the next field
5099	jjr = jjr + ijpj
5100	jji = jji + ijpj
5101	END DO ! loop over fields
5102
5103	CASE DEFAULT ! * closed : the code probably never go through
5104
5105	DO ifield=1, nfields, 1
5106
5107	! Set-up stuff dependent on whether this field is real or integer
5108	field_is_real = .FALSE.
5109	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
5110	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
5111
5112	! Set up stuff dependent on whether this field is
5113	! 2- or 3-dimensional
5114	IF(fields_all_3d)THEN
5115	klimit=jpk
5116	ELSE IF(fields_all_2d)THEN
5117	klimit = 1
5118	ELSE
5119	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
5120	ASSOCIATED(list(ifield)%i3dptr) )THEN
5121	klimit=jpk
5122	ELSE
5123	klimit = 1
5124	END IF
5125	END IF
5126
5127	SELECT CASE ( list(ifield)%grid)
5128
5129	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5130	IF(field_is_real)THEN
5131	#if defined key_z_first
5132	DO ii = 1, jpiglo, 1
5133	DO jk = 1, klimit, 1
5134	#else
5135	DO jk = 1, klimit, 1
5136	DO ii = 1, jpiglo, 1
5137	#endif
5138	ztab(ii, 1 , jk) = 0_wp
5139	ztab(ii,jjr, jk) = 0_wp
5140	END DO
5141	END DO
5142	ELSE
5143	#if defined key_z_first
5144	DO ii = 1, jpiglo, 1
5145	DO jk = 1, klimit, 1
5146	#else
5147	DO jk = 1, klimit, 1
5148	DO ii = 1, jpiglo, 1
5149	#endif
5150	iztab(ii, 1 ,jk) = 0
5151	iztab(ii,jji,jk) = 0
5152	END DO
5153	END DO
5154	END IF
5155
5156	CASE ( 'F' ) ! F-point
5157	IF(field_is_real)THEN
5158	ztab(:,jjr,1:klimit) = 0_wp
5159	ELSE
5160	iztab(:,jji,1:klimit) = 0
5161	END IF
5162
5163	CASE ( 'I' ) ! ice U-V point
5164	IF(field_is_real)THEN
5165	#if defined key_z_first
5166	DO ii = 1, jpiglo, 1
5167	DO jk = 1, klimit, 1
5168	#else
5169	DO jk = 1, klimit, 1
5170	DO ii = 1, jpiglo, 1
5171	#endif
5172	ztab(ii, 1 ,jk) = 0_wp
5173	ztab(ii,jjr,jk) = 0_wp
5174	END DO
5175	END DO
5176	ELSE
5177	#if defined key_z_first
5178	DO ii = 1, jpiglo, 1
5179	DO jk = 1, klimit, 1
5180	#else
5181	DO jk = 1, klimit, 1
5182	DO ii = 1, jpiglo, 1
5183	#endif
5184	iztab(ii, 1 ,jk) = 0
5185	iztab(ii,jji,jk) = 0
5186	END DO
5187	END DO
5188	END IF
5189
5190	END SELECT
5191
5192	! Move to the next set of ijpj rows corresponding to the next field
5193	jjr = jjr + ijpj
5194	jji = jji + ijpj
5195	END DO ! loop over fields
5196
5197	END SELECT
5198
5199
5200	! End of slab
5201	! ===========
5202
5203	!! Scatter back to original array(s)
5204	!!$ DO jr = 1, ndim_rank_north
5205	!!$ jproc=nrank_north(jr)+1
5206	!!$ ildi=nldit (jproc)
5207	!!$ ilei=nleit (jproc)
5208	!!$ iilb=pielb(jproc)
5209	!!$ IF(.NOT. fields_all_int)THEN
5210	!!$ znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5211	!!$ ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5212	!!$ END IF
5213	!!$ IF(.NOT. fields_all_real)THEN
5214	!!$ iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5215	!!$ iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5216	!!$ END IF
5217	!!$ END DO
5218
5219	IF(fields_all_int)THEN
5220
5221	DO jr = 1, ndim_rank_north
5222	jproc=nrank_north(jr)+1
5223	ildi=nldit (jproc)
5224	ilei=nleit (jproc)
5225	iilb=pielb(jproc)
5226	! ARPDBG - make loop ordering explicit for performance?
5227	iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5228	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5229	END DO
5230
5231	ELSE IF(fields_all_real)THEN
5232
5233	DO jr = 1, ndim_rank_north
5234	jproc=nrank_north(jr)+1
5235	ildi=nldit (jproc)
5236	ilei=nleit (jproc)
5237	iilb=pielb(jproc)
5238	! ARPDBG - make loop ordering explicit for performance?
5239	znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5240	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5241	END DO
5242
5243	ELSE ! Have some real and some integer fields
5244
5245	DO jr = 1, ndim_rank_north
5246	jproc=nrank_north(jr)+1
5247	ildi=nldit (jproc)
5248	ilei=nleit (jproc)
5249	iilb=pielb(jproc)
5250	! ARPDBG - make loop ordering explicit for performance?
5251	znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5252	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5253	iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5254	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5255	END DO
5256
5257	END IF
5258
5259	ENDIF ! only done on proc 0 of ncomm_north
5260
5261	CALL prof_region_end(ARPNORTHAPPLYSYMM, iprofStat)
5262
5263	CALL prof_region_begin(NORTHLISTSCATTER, "NorthListScatter", iprofStat)
5264
5265	IF ( npolj /= 0 ) THEN
5266	IF(.NOT. fields_all_int)THEN
5267	itaille=nwidthmaxishiftrklimit
5268	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
5269	znorthloc, itaille,MPI_DOUBLE_PRECISION, &
5270	0, ncomm_north,ierr)
5271	END IF
5272	IF(.NOT. fields_all_real)THEN
5273	itaille=nwidthmaxishiftiklimit
5274	CALL MPI_SCATTER(iznorthgloio,itaille,MPI_INTEGER, &
5275	iznorthloc, itaille,MPI_INTEGER, &
5276	0, ncomm_north,ierr)
5277
5278	END IF
5279	ENDIF
5280
5281	! put back the last ijpj jlines of each field
5282	ishiftr = 0
5283	ishifti = 0
5284	DO ifield=1,nfields,1
5285
5286	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
5287	DO ij = 1, ijpj, 1
5288	jj = nlcj - ijpj + ij
5289	list(ifield)%r2dptr(nldi:nlei,jj)= znorthloc(nldi:nlei,ij+ishiftr,1)
5290	END DO
5291	ishiftr = ishiftr + ijpj
5292	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
5293	#if defined key_z_first
5294	DO ij = 1, ijpj, 1
5295	jj = nlcj - ijpj + ij
5296	DO jk = 1, jpk
5297	#else
5298	DO jk = 1, jpk
5299	DO ij = 1, ijpj, 1
5300	jj = nlcj - ijpj + ij
5301	#endif
5302	! ARPDBG Make loop over i explicit for performance?
5303	list(ifield)%r3dptr(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij+ishiftr,jk)
5304	END DO
5305	END DO
5306	ishiftr = ishiftr + ijpj
5307	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
5308	DO ij = 1, ijpj, 1
5309	jj = nlcj - ijpj + ij
5310	list(ifield)%i2dptr(nldi:nlei,jj)= iznorthloc(nldi:nlei,ij+ishifti,1)
5311	END DO
5312	ishifti = ishifti + ijpj
5313	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
5314	#if defined key_z_first
5315	DO ij = 1, ijpj, 1
5316	jj = nlcj - ijpj + ij
5317	DO jk = 1, jpk
5318	#else
5319	DO jk = 1, jpk
5320	DO ij = 1, ijpj, 1
5321	jj = nlcj - ijpj + ij
5322	#endif
5323	! ARPDBG Make loop over i explicit for performance?
5324	list(ifield)%i3dptr(nldi:nlei,jj,jk)= iznorthloc(nldi:nlei,ij+ishifti,jk)
5325	END DO
5326	END DO
5327	ishifti = ishifti + ijpj
5328	END IF
5329	END DO ! loop over fields
5330
5331	CALL prof_region_end(NORTHLISTSCATTER, iprofStat)
5332
5333	#endif /* key_mpp_mpi */
5334
5335	CALL prof_region_end(ARPNORTHLISTCOMMS, iprofStat)
5336
5337	END SUBROUTINE mpp_lbc_north_list
5338
5339	!============================================================================
5340
5341	SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn)
5342	!!---------------------------------------------------------------------
5343	!! * routine mpp_lbc_north_2d *
5344	!!
5345	!! ** Purpose :
5346	!! Ensure proper north fold horizontal bondary condition in mpp
5347	!! configuration in case of jpn1 > 1 (for 2d array )
5348	!!
5349	!! ** Method :
5350	!! Gather the 4 northern lines of the global domain on 1 processor and
5351	!! apply lbc north-fold on this sub array. Then scatter the fold array
5352	!! back to the processors.
5353	!!
5354	!! History :
5355	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5356	!! from lbc routine
5357	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding
5358	!! rules of lbc_lnk
5359	!!----------------------------------------------------------------------
5360	USE par_oce, ONLY : jpni, jpi, jpj
5361	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
5362	nwidthmax
5363	USE mapcomm_mod, ONLY : pielb, piesub
5364	USE lib_mpp, ONLY : ctl_stop
5365	USE arpdebugging, ONLY: dump_array
5366	IMPLICIT none
5367	!! * Arguments
5368	CHARACTER(len=1), INTENT( in ) :: &
5369	cd_type ! nature of pt2d grid-points
5370	! ! = T , U , V , F or W gridpoints
5371	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
5372	pt2d ! 2D array on which the boundary condition is applied
5373	REAL(wp), INTENT( in ) :: &
5374	psgn ! control of the sign change
5375	! ! = -1. , the sign is changed if north fold boundary
5376	! ! = 1. , the sign is kept if north fold boundary
5377
5378	!! * Local declarations
5379
5380	INTEGER :: ijpj
5381	INTEGER :: ji, jj, jr, jproc
5382	INTEGER :: ierr
5383	INTEGER :: ildi,ilei,iilb
5384	INTEGER :: ijpjm1,ij,ijt,iju
5385	INTEGER :: itaille
5386
5387	REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: ztab2
5388	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio2
5389	REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: znorthloc2
5390	!!----------------------------------------------------------------------
5391	!! OPA 8.5, LODYC-IPSL (2002)
5392	!!----------------------------------------------------------------------
5393	! If we get in this routine it's because : North fold condition and mpp
5394	! with more than one PE across i : we deal only with the North condition
5395
5396	! Set local from public PARAMETER
5397	ijpj = num_nfold_rows
5398
5399	CALL prof_region_begin(ARPNORTHCOMMS2D, "North2D", iprofStat)
5400
5401	#if defined key_mpp_mpi
5402
5403	IF(.not. ALLOCATED(ztab2))THEN
5404
5405	ALLOCATE(ztab2(jpiglo,ijpj), &
5406	znorthgloio2(nwidthmax,ijpj,ndim_rank_north), &
5407	znorthloc2(nwidthmax,ijpj), &
5408	STAT=ierr)
5409	IF(ierr .ne. 0)THEN
5410	CALL ctl_stop('STOP','mpp_lbc_north_2d: memory allocation failed' )
5411	END IF
5412	END IF
5413
5414	! 0. Sign setting
5415	! ---------------
5416
5417	ijpjm1=ijpj-1
5418
5419	! put the last ijpj jlines of pt2d into znorthloc2
5420	znorthloc2(:,:) = 0_wp ! because of padding for nwidthmax
5421
5422	! jeub is the upper j limit of current domain in global coords
5423	!
5424	! \|======================= jpjglo ^
5425	! <Trimmed> \| /\|\
5426	! \|----------------------- jpjglo-1 \|
5427	! \| \|
5428	! \|---------jeub--------------------------------
5429	! \| \| j
5430	! \|--------------------------------------------
5431	! \| \| \|
5432	! \|-------------------------------------------- \|
5433	!
5434	! No. of trimmed rows = jpjglo - jeub
5435	! No. of valid rows for n-fold = ijpj - <no. trimmed rows>
5436	! = ijpj - jpjglo + jeub
5437	! Need an iterator that ends with max value ijpj and has (ijpj-jpjglo+jeub)
5438	! distinct values so start point must be:
5439	! ij_start = ijpj - (ijpj-jpjglo+jeub) + 1 = jpjglo - jeub + 1
5440	! => if jeub == jpjglo then we recover a starting value of 1.
5441	! if jeub == jpjglo - 10 then ij_start = 11 so no loop iterations
5442	! will be performed.
5443
5444	#if defined NO_NFOLD_GATHER
5445	! Post receives for other PE's north-fold data
5446	DO iproc = 1, ndim_rank_north, 1
5447
5448	IF( iproc-1 == nrank_north(iproc) ) CYCLE ! Skip this PE
5449
5450	CALL MPI_IRecv(znorthgloio2(), north_pts(iproc), MPI_DOUBLE_PRECISION, &
5451	nrank_north(iproc), iproc, tag, ncomm_north, &
5452	nexch_flag(iproc) )
5453	END DO
5454	#endif
5455
5456	DO ij = jpjglo - jeub + 1, ijpj, 1
5457
5458	jj = nlcj - ijpj + ij
5459	znorthloc2(nldi:nlei,ij)=pt2d(nldi:nlei,jj)
5460	END DO
5461
5462	! CALL dump_array(0,'znorthloc2',znorthloc2,withHalos=.TRUE.,toGlobal=.FALSE.)
5463
5464	IF (npolj /= 0 ) THEN
5465	! Build in proc 0 of ncomm_north the znorthgloio2
5466	znorthgloio2(:,:,:) = 0_wp
5467	itaille=nwidthmax*ijpj
5468	CALL MPI_GATHER(znorthloc2,itaille,MPI_DOUBLE_PRECISION, &
5469	znorthgloio2,itaille,MPI_DOUBLE_PRECISION, &
5470	0, ncomm_north, ierr)
5471
5472	ENDIF
5473
5474	IF (narea == north_root+1 ) THEN
5475	! recover the global north array
5476	! ztab2 has full width of global domain
5477	ztab2(:,:) = 0_wp
5478
5479	DO jr = 1, ndim_rank_north
5480	jproc=nrank_north(jr)+1
5481	ildi=nldit(jproc)
5482	ilei=nleit(jproc)
5483	iilb=pielb(jproc)
5484	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)= &
5485	znorthgloio2(ildi:ilei,1:ijpj,jr)
5486	END DO
5487
5488	! CALL dump_array(0,'ztab2',ztab2,withHalos=.TRUE.,toGlobal=.FALSE.)
5489
5490	! 2. North-Fold boundary conditions
5491	! ----------------------------------
5492
5493	SELECT CASE ( npolj )
5494
5495	CASE ( 3, 4 ) ! * North fold T-point pivot
5496
5497	ztab2( 1 ,ijpj) = 0._wp
5498	ztab2(jpiglo,ijpj) = 0._wp
5499
5500	SELECT CASE ( cd_type )
5501
5502	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
5503	DO ji = 2, jpiglo
5504	ijt = jpiglo-ji+2
5505	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2)
5506	END DO
5507	DO ji = jpiglo/2+1, jpiglo
5508	ijt = jpiglo-ji+2
5509	ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1)
5510	END DO
5511
5512	CASE ( 'U' ) ! U-point
5513	DO ji = 1, jpiglo-1
5514	iju = jpiglo-ji+1
5515	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-2)
5516	END DO
5517	DO ji = jpiglo/2, jpiglo-1
5518	iju = jpiglo-ji+1
5519	ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1)
5520	END DO
5521
5522	CASE ( 'V' ) ! V-point
5523	DO ji = 2, jpiglo
5524	ijt = jpiglo-ji+2
5525	ztab2(ji,ijpj-1) = psgn * ztab2(ijt,ijpj-2)
5526	ztab2(ji,ijpj ) = psgn * ztab2(ijt,ijpj-3)
5527	END DO
5528
5529	CASE ( 'F' , 'G' ) ! F-point
5530	DO ji = 1, jpiglo-1
5531	iju = jpiglo-ji+1
5532	ztab2(ji,ijpj-1) = psgn * ztab2(iju,ijpj-2)
5533	ztab2(ji,ijpj ) = psgn * ztab2(iju,ijpj-3)
5534	END DO
5535
5536	CASE ( 'I' ) ! ice U-V point
5537	ztab2(2,ijpj) = psgn * ztab2(3,ijpj-1)
5538	DO ji = 3, jpiglo
5539	iju = jpiglo - ji + 3
5540	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1)
5541	END DO
5542
5543	END SELECT
5544
5545	CASE ( 5, 6 ) ! * North fold F-point pivot
5546
5547	ztab2( 1 ,ijpj) = 0._wp
5548	ztab2(jpiglo,ijpj) = 0._wp
5549
5550	SELECT CASE ( cd_type )
5551
5552	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
5553	DO ji = 1, jpiglo
5554	ijt = jpiglo-ji+1
5555	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-1)
5556	END DO
5557
5558	CASE ( 'U' ) ! U-point
5559	DO ji = 1, jpiglo-1
5560	iju = jpiglo-ji
5561	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1)
5562	END DO
5563
5564	CASE ( 'V' ) ! V-point
5565	DO ji = 1, jpiglo
5566	ijt = jpiglo-ji+1
5567	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2)
5568	END DO
5569	DO ji = jpiglo/2+1, jpiglo
5570	ijt = jpiglo-ji+1
5571	ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1)
5572	END DO
5573
5574	CASE ( 'F' , 'G' ) ! F-point
5575	DO ji = 1, jpiglo-1
5576	iju = jpiglo-ji
5577	ztab2(ji,ijpj ) = psgn * ztab2(iju,ijpj-2)
5578	END DO
5579	DO ji = jpiglo/2+1, jpiglo-1
5580	iju = jpiglo-ji
5581	ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1)
5582	END DO
5583
5584	CASE ( 'I' ) ! ice U-V point
5585	ztab2( 2 ,ijpj) = 0.e0
5586	DO ji = 2 , jpiglo-1
5587	ijt = jpiglo - ji + 2
5588	ztab2(ji,ijpj)= 0.5 * ( ztab2(ji,ijpj-1) + psgn * ztab2(ijt,ijpj-1) )
5589	END DO
5590
5591	END SELECT
5592
5593	CASE DEFAULT ! * closed : the code probably never go through
5594
5595	SELECT CASE ( cd_type)
5596
5597	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5598	ztab2(:, 1 ) = 0._wp
5599	ztab2(:,ijpj) = 0._wp
5600
5601	CASE ( 'F' ) ! F-point
5602	ztab2(:,ijpj) = 0._wp
5603
5604	CASE ( 'I' ) ! ice U-V point
5605	ztab2(:, 1 ) = 0._wp
5606	ztab2(:,ijpj) = 0._wp
5607
5608	END SELECT
5609
5610	END SELECT
5611
5612	! End of slab
5613	! ===========
5614
5615	!! Scatter back to pt2d
5616	DO jr = 1, ndim_rank_north
5617	jproc=nrank_north(jr)+1
5618	ildi=nldit (jproc)
5619	ilei=nleit (jproc)
5620	iilb=pielb(jproc)
5621	znorthgloio2(ildi:ilei,1:ijpj,jr)= &
5622	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
5623	END DO
5624
5625	ENDIF ! only done on proc 0 of ncomm_north
5626
5627	IF ( npolj /= 0 ) THEN
5628	itaille=nwidthmax*ijpj
5629	CALL MPI_SCATTER(znorthgloio2,itaille,MPI_DOUBLE_PRECISION, &
5630	znorthloc2, itaille,MPI_DOUBLE_PRECISION, &
5631	0,ncomm_north,ierr)
5632	ENDIF
5633
5634	! Put the last ijpj jlines of pt2d into znorthloc2 while allowing
5635	! for any trimming of domain (see earlier comments and diagram)
5636	DO ij = jpjglo - jeub + 1, ijpj, 1
5637	jj = nlcj - ijpj + ij
5638	pt2d(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
5639	END DO
5640
5641	#endif /* key_mpp_mpi */
5642
5643	CALL prof_region_end(ARPNORTHCOMMS2D, iprofStat)
5644
5645	END SUBROUTINE mpp_lbc_north_2d
5646
5647	!====================================================================
5648
5649	SUBROUTINE mpp_lbc_north_i2d ( ib2, cd_type, isgn)
5650	!!---------------------------------------------------------------------
5651	!! * routine mpp_lbc_north_2d *
5652	!!
5653	!! ** Purpose :
5654	!! Ensure proper north fold horizontal bondary condition in mpp
5655	!! configuration in case of jpn1 > 1 (for 2d array )
5656	!!
5657	!! ** Method :
5658	!! Gather the 4 northern lines of the global domain on 1 processor and
5659	!! apply lbc north-fold on this sub array. Then scatter the fold array
5660	!! back to the processors.
5661	!!
5662	!! History :
5663	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5664	!! from lbc routine
5665	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp,
5666	!! coding rules of lbc_lnk
5667	!!----------------------------------------------------------------------
5668	USE par_oce, ONLY : jpni, jpi, jpj
5669	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, &
5670	nlcj, nwidthmax
5671	USE mapcomm_mod, ONLY : pielb, piesub
5672	USE lib_mpp, ONLY : ctl_stop
5673	IMPLICIT none
5674	!! * Arguments
5675	CHARACTER(len=1), INTENT( in ) :: &
5676	cd_type ! nature of ib2 grid-points
5677	! ! = T , U , V , F or W gridpoints
5678	INTEGER, DIMENSION(jpi,jpj), INTENT( inout ) :: &
5679	ib2 ! 2D array on which the boundary condition is applied
5680	INTEGER, INTENT( in ) :: &
5681	isgn ! control of the sign change
5682	! ! = -1. , the sign is changed if north fold boundary
5683	! ! = 1. , the sign is kept if north fold boundary
5684
5685	!! * Local declarations
5686
5687	INTEGER :: ijpj
5688	INTEGER :: ji, jj, jr, jproc
5689	INTEGER :: ierr
5690	INTEGER :: ildi,ilei,iilb
5691	INTEGER :: ijpjm1,ij,ijt,iju
5692	INTEGER :: itaille
5693
5694	INTEGER, DIMENSION(:,:), ALLOCATABLE :: ztab2
5695	INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio2
5696	INTEGER, DIMENSION(:,:), ALLOCATABLE :: znorthloc2
5697	!!----------------------------------------------------------------------
5698	!! OPA 8.5, LODYC-IPSL (2002)
5699	!!----------------------------------------------------------------------
5700	! If we get in this routine it's because : North fold condition and mpp
5701	! with more than one PE across i : we deal only with the North condition
5702
5703	#if defined key_mpp_mpi
5704
5705	ijpj = num_nfold_rows
5706	ijpjm1=ijpj - 1
5707
5708
5709	IF(.not. ALLOCATED(ztab2))THEN
5710
5711	ALLOCATE(ztab2(jpiglo,ijpj), &
5712	znorthgloio2(nwidthmax,ijpj,jpni), &
5713	znorthloc2(nwidthmax,ijpj), &
5714	STAT=ierr)
5715	IF(ierr .ne. 0)THEN
5716	CALL ctl_stop('STOP','mpp_lbc_north_i2d: memory allocation failed')
5717	END IF
5718	END IF
5719
5720	! 0. Sign setting
5721	! ---------------
5722
5723	! Put the last ijpj jlines of ib2 into znorthloc2 while allowing
5724	! for any trimming of domain (see earlier comments and diagram in
5725	! mpp_lbc_north_2d).
5726	znorthloc2(:,:) = 0 ! because of padding for nwidthmax
5727	DO ij = jpjglo - jeub + 1, ijpj, 1
5728	jj = nlcj - ijpj + ij
5729	znorthloc2(nldi:nlei,ij)=ib2(nldi:nlei,jj)
5730	END DO
5731
5732	IF (npolj /= 0 ) THEN
5733	! Build in proc 0 of ncomm_north the znorthgloio2
5734	znorthgloio2(:,:,:) = 0
5735	itaille=nwidthmax*ijpj
5736	CALL MPI_GATHER(znorthloc2,itaille,MPI_INTEGER, &
5737	znorthgloio2,itaille,MPI_INTEGER,0,&
5738	ncomm_north,ierr)
5739	ENDIF
5740
5741	IF (narea == north_root+1 ) THEN
5742	! recover the global north array
5743	ztab2(:,:) = 0
5744
5745	DO jr = 1, ndim_rank_north
5746	jproc=nrank_north(jr)+1
5747	ildi=nldit (jproc)
5748	ilei=nleit (jproc)
5749	iilb=pielb(jproc)
5750	!WRITE (,)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',&
5751	! ildi, ilei, iilb, ijpj
5752	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) = &
5753	znorthgloio2(ildi:ilei,1:ijpj,jr)
5754	END DO
5755
5756
5757	! 2. North-Fold boundary conditions
5758	! ----------------------------------
5759
5760	SELECT CASE ( npolj )
5761
5762	CASE ( 3, 4 ) ! * North fold T-point pivot
5763
5764	ztab2( 1 ,ijpj) = 0
5765	ztab2(jpiglo,ijpj) = 0
5766
5767	SELECT CASE ( cd_type )
5768
5769	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
5770	DO ji = 2, jpiglo
5771	ijt = jpiglo-ji+2
5772	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2)
5773	END DO
5774	DO ji = jpiglo/2+1, jpiglo
5775	ijt = jpiglo-ji+2
5776	ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1)
5777	END DO
5778
5779	CASE ( 'U' ) ! U-point
5780	DO ji = 1, jpiglo-1
5781	iju = jpiglo-ji+1
5782	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-2)
5783	END DO
5784	DO ji = jpiglo/2, jpiglo-1
5785	iju = jpiglo-ji+1
5786	ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1)
5787	END DO
5788
5789	CASE ( 'V' ) ! V-point
5790	DO ji = 2, jpiglo
5791	ijt = jpiglo-ji+2
5792	ztab2(ji,ijpj-1) = isgn * ztab2(ijt,ijpj-2)
5793	ztab2(ji,ijpj ) = isgn * ztab2(ijt,ijpj-3)
5794	END DO
5795
5796	CASE ( 'F' , 'G' ) ! F-point
5797	DO ji = 1, jpiglo-1
5798	iju = jpiglo-ji+1
5799	ztab2(ji,ijpj-1) = isgn * ztab2(iju,ijpj-2)
5800	ztab2(ji,ijpj ) = isgn * ztab2(iju,ijpj-3)
5801	END DO
5802
5803	CASE ( 'I' ) ! ice U-V point
5804	ztab2(2,ijpj) = isgn * ztab2(3,ijpj-1)
5805	DO ji = 3, jpiglo
5806	iju = jpiglo - ji + 3
5807	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1)
5808	END DO
5809
5810	END SELECT
5811
5812	CASE ( 5, 6 ) ! * North fold F-point pivot
5813
5814	ztab2( 1 ,ijpj) = 0
5815	ztab2(jpiglo,ijpj) = 0
5816
5817	SELECT CASE ( cd_type )
5818
5819	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
5820	DO ji = 1, jpiglo
5821	ijt = jpiglo-ji+1
5822	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-1)
5823	END DO
5824
5825	CASE ( 'U' ) ! U-point
5826	DO ji = 1, jpiglo-1
5827	iju = jpiglo-ji
5828	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1)
5829	END DO
5830
5831	CASE ( 'V' ) ! V-point
5832	DO ji = 1, jpiglo
5833	ijt = jpiglo-ji+1
5834	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2)
5835	END DO
5836	DO ji = jpiglo/2+1, jpiglo
5837	ijt = jpiglo-ji+1
5838	ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1)
5839	END DO
5840
5841	CASE ( 'F' , 'G' ) ! F-point
5842	DO ji = 1, jpiglo-1
5843	iju = jpiglo-ji
5844	ztab2(ji,ijpj ) = isgn * ztab2(iju,ijpj-2)
5845	END DO
5846	DO ji = jpiglo/2+1, jpiglo-1
5847	iju = jpiglo-ji
5848	ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1)
5849	END DO
5850
5851	CASE ( 'I' ) ! ice U-V point
5852	ztab2( 2 ,ijpj) = 0
5853	DO ji = 2 , jpiglo-1
5854	ijt = jpiglo - ji + 2
5855	ztab2(ji,ijpj)= NINT(0.5 * ( ztab2(ji,ijpj-1) + &
5856	isgn * ztab2(ijt,ijpj-1) ))
5857	END DO
5858
5859	END SELECT
5860
5861	CASE DEFAULT ! * closed : the code probably never go through
5862
5863	SELECT CASE ( cd_type)
5864
5865	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5866	ztab2(:, 1 ) = 0
5867	ztab2(:,ijpj) = 0
5868
5869	CASE ( 'F' ) ! F-point
5870	ztab2(:,ijpj) = 0
5871
5872	CASE ( 'I' ) ! ice U-V point
5873	ztab2(:, 1 ) = 0
5874	ztab2(:,ijpj) = 0
5875
5876	END SELECT
5877
5878	END SELECT
5879
5880	! End of slab
5881	! ===========
5882
5883	!! Scatter back to ib2
5884	DO jr = 1, ndim_rank_north
5885	jproc=nrank_north(jr)+1
5886	ildi=nldit (jproc)
5887	ilei=nleit (jproc)
5888	iilb=pielb(jproc)
5889	znorthgloio2(ildi:ilei,1:ijpj,jr) = &
5890	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
5891	END DO
5892
5893	ENDIF ! only done on proc 0 of ncomm_north
5894
5895	IF ( npolj /= 0 ) THEN
5896	itaille=nwidthmax*ijpj
5897	CALL MPI_SCATTER(znorthgloio2,itaille,MPI_INTEGER, &
5898	znorthloc2, itaille,MPI_INTEGER, &
5899	0, ncomm_north, ierr)
5900	ENDIF
5901
5902	! put in the last ijpj jlines of ib2 from znorthloc2 while allowing
5903	! for any trimming of domain (see earlier comments and diagram in
5904	! mpp_lbc_north_2d).
5905	DO ij = jpjglo - jeub + 1, ijpj, 1
5906	jj = nlcj - ijpj + ij
5907	ib2(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
5908	END DO
5909	WRITE(,) 'ARPDBG: finished in mpp_lbc_north_i2d'
5910
5911	#endif /* key_mpp_mpi */
5912
5913	END SUBROUTINE mpp_lbc_north_i2d
5914
5915	!=================================================================
5916
5917	SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
5918	!!---------------------------------------------------------------------
5919	!! * routine mpp_lbc_north_3d *
5920	!!
5921	!! ** Purpose :
5922	!! Ensure proper north fold horizontal bondary condition in mpp
5923	!! configuration in case of jpn1 > 1
5924	!!
5925	!! ** Method :
5926	!! Gather the 4 northern lines of the global domain on 1 processor
5927	!! and apply lbc north-fold on this sub array. Then scatter the
5928	!! fold array back to the processors.
5929	!!
5930	!! History :
5931	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5932	!! from lbc routine
5933	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp,
5934	!! coding rules of lbc_lnk
5935	!!----------------------------------------------------------------------
5936	USE par_oce, ONLY : jpni
5937	USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, nwidthmax
5938	USE mapcomm_mod, ONLY : pielb, piesub
5939	USE lib_mpp, ONLY : ctl_stop
5940	IMPLICIT none
5941	!! * Arguments
5942	CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points
5943	! ! = T, U, V, F or W gridp'ts
5944	REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: &
5945	pt3d ! 3D array on which the boundary condition is applied
5946	REAL(wp), INTENT( in ) :: &
5947	psgn ! control of the sign change
5948	! ! = -1. , the sign is changed if north fold boundary
5949	! ! = 1. , the sign is kept if north fold boundary
5950
5951	!! * Local declarations
5952	INTEGER :: ijpj
5953	INTEGER :: ji, jj, jk, jr, jproc
5954	INTEGER :: ierr
5955	INTEGER :: ildi,ilei,iilb
5956	INTEGER :: ijpjm1,ij,ijt,iju
5957	INTEGER :: itaille
5958	!FTRANS ztab :I :I :z
5959	!FTRANS znorthgloio :I :I :z :
5960	!FTRANS znorthloc :I :I :z
5961	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab
5962	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
5963	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc
5964	!!----------------------------------------------------------------------
5965
5966	! If we get in this routine it's because : North fold condition and
5967	! mpp with more than one proc across i : we deal only with the North
5968	! condition
5969	#if defined key_mpp_mpi
5970
5971	ijpj = num_nfold_rows
5972	ijpjm1=ijpj - 1
5973
5974	IF(.not. ALLOCATED(ztab))THEN
5975
5976	ALLOCATE(ztab(jpiglo,ijpj,jpkorig), &
5977	znorthgloio(nwidthmax,ijpj,jpkorig,jpni), &
5978	znorthloc(nwidthmax,ijpj,jpkorig), &
5979	STAT=ierr)
5980	IF(ierr .ne. 0)THEN
5981	CALL ctl_stop( ' mpp_lbc_north_3d: memory allocation failed' )
5982	#if defined key_mpp_mpi
5983	CALL mpi_finalize( ierr )
5984	#endif
5985	STOP
5986	END IF
5987	END IF
5988
5989	CALL prof_region_begin(NORTH3DGATHER, "North3DGather", iprofStat)
5990
5991	! 0. Sign setting
5992	! ---------------
5993
5994	! Put the last ijpj jlines of pt3d into znorthloc while allowing
5995	! for any trimming of domain (see earlier comments and diagram in
5996	! mpp_lbc_north_2d).
5997	! Have to initialise all to zero in case chunks are missing due to domain
5998	! trimming
5999	znorthloc(:,:,:) = 0.0_wp
6000	#if defined key_z_first
6001	DO ij = jpjglo - jeub + 1, ijpj, 1
6002	jj = nlcj - ijpj + ij
6003	DO jk = 1, jpk
6004	#else
6005	DO jk = 1, jpk
6006	DO ij = jpjglo - jeub + 1, ijpj, 1
6007	jj = nlcj - ijpj + ij
6008	#endif
6009	znorthloc(nldi:nlei,ij,jk) = pt3d(nldi:nlei,jj,jk)
6010	END DO
6011	END DO
6012
6013
6014	IF (npolj /= 0 ) THEN
6015	! Build in proc 0 of ncomm_north the znorthgloio
6016
6017	#ifdef key_mpp_shmem
6018	not done : compiler error
6019	#elif defined key_mpp_mpi
6020	itaille=nwidthmaxjpkorigijpj
6021	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, &
6022	znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
6023	0,ncomm_north,ierr)
6024	#endif
6025
6026	ENDIF
6027
6028	CALL prof_region_end(NORTH3DGATHER, iprofStat)
6029
6030	CALL prof_region_begin(NORTH3DAPPSYMM, "North3DApplySymm", iprofStat)
6031
6032	IF (narea == north_root+1 ) THEN
6033	! recover the global north array
6034	ztab(:,:,:) = 0_wp
6035
6036	DO jr = 1, ndim_rank_north
6037	jproc = nrank_north(jr) + 1
6038	ildi = nldit (jproc)
6039	ilei = nleit (jproc)
6040	iilb = pielb(jproc)
6041	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = &
6042	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr)
6043	END DO
6044
6045
6046	! Horizontal slab
6047	! ===============
6048	#if defined key_z_first
6049
6050	! 2. North-Fold boundary conditions
6051	! ----------------------------------
6052
6053	SELECT CASE ( npolj )
6054
6055	CASE ( 3, 4 ) ! * North fold T-point pivot
6056
6057	DO jk = 1, jpk
6058	ztab( 1 ,ijpj,jk) = 0.0_wp
6059	ztab(jpiglo,ijpj,jk) = 0.0_wp
6060	END DO
6061
6062	SELECT CASE ( cd_type )
6063
6064	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6065	DO ji = 2, jpiglo
6066	ijt = jpiglo-ji+2
6067	DO jk = 1, jpk
6068	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6069	END DO
6070	END DO
6071	DO ji = jpiglo/2+1, jpiglo
6072	ijt = jpiglo-ji+2
6073	DO jk = 1, jpk, 1
6074	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6075	END DO
6076	END DO
6077
6078	CASE ( 'U' ) ! U-point
6079	DO ji = 1, jpiglo-1
6080	iju = jpiglo-ji+1
6081	DO jk = 1, jpk, 1
6082	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
6083	END DO
6084	END DO
6085	DO ji = jpiglo/2, jpiglo-1
6086	iju = jpiglo-ji+1
6087	DO jk = 1, jpk, 1
6088	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6089	END DO
6090	END DO
6091
6092	CASE ( 'V' ) ! V-point
6093	DO ji = 2, jpiglo
6094	ijt = jpiglo-ji+2
6095	DO jk = 1, jpk, 1
6096	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
6097	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
6098	END DO
6099	END DO
6100
6101	CASE ( 'F' , 'G' ) ! F-point
6102	DO ji = 1, jpiglo-1
6103	iju = jpiglo-ji+1
6104	DO jk = 1, jpk, 1
6105	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
6106	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
6107	END DO
6108	END DO
6109
6110	END SELECT
6111
6112	CASE ( 5, 6 ) ! * North fold F-point pivot
6113
6114	DO jk = 1, jpk, 1
6115	ztab( 1 ,ijpj,jk) = 0._wp
6116	ztab(jpiglo,ijpj,jk) = 0._wp
6117	END DO
6118
6119	SELECT CASE ( cd_type )
6120
6121	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6122	DO ji = 1, jpiglo
6123	ijt = jpiglo-ji+1
6124	DO jk = 1, jpk, 1
6125	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
6126	END DO
6127	END DO
6128
6129	CASE ( 'U' ) ! U-point
6130	DO ji = 1, jpiglo-1
6131	iju = jpiglo-ji
6132	DO jk = 1, jpk, 1
6133	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
6134	END DO
6135	END DO
6136
6137	CASE ( 'V' ) ! V-point
6138	DO ji = 1, jpiglo
6139	ijt = jpiglo-ji+1
6140	DO jk = 1, jpk, 1
6141	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6142	END DO
6143	END DO
6144	DO ji = jpiglo/2+1, jpiglo
6145	ijt = jpiglo-ji+1
6146	DO jk = 1, jpk, 1
6147	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6148	END DO
6149	END DO
6150
6151	CASE ( 'F' , 'G' ) ! F-point
6152	DO ji = 1, jpiglo-1
6153	iju = jpiglo-ji
6154	DO jk = 1, jpk, 1
6155	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
6156	END DO
6157	END DO
6158	DO ji = jpiglo/2+1, jpiglo-1
6159	iju = jpiglo-ji
6160	DO jk = 1, jpk, 1
6161	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6162	END DO
6163	END DO
6164
6165	END SELECT
6166
6167	CASE DEFAULT ! * closed
6168
6169	SELECT CASE ( cd_type)
6170
6171	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6172	DO ji = 1, jpiglo, 1
6173	DO jk = 1, jpk, 1
6174	ztab(ji, 1 ,jk) = 0.0_wp
6175	ztab(ji,ijpj,jk) = 0.0_wp
6176	END DO
6177	END DO
6178
6179	CASE ( 'F' ) ! F-point
6180	DO ji = 1, jpiglo, 1
6181	DO jk = 1, jpk, 1
6182	ztab(ji,ijpj,jk) = 0.0_wp
6183	END DO
6184	END DO
6185
6186	END SELECT
6187
6188	END SELECT
6189
6190	! End of slab
6191	! ===========
6192	#else
6193	DO jk = 1, jpk
6194
6195
6196	! 2. North-Fold boundary conditions
6197	! ----------------------------------
6198
6199	SELECT CASE ( npolj )
6200
6201	CASE ( 3, 4 ) ! * North fold T-point pivot
6202
6203	ztab( 1 ,ijpj,jk) = 0.0_wp
6204	ztab(jpiglo,ijpj,jk) = 0.0_wp
6205
6206	SELECT CASE ( cd_type )
6207
6208	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6209	DO ji = 2, jpiglo
6210	ijt = jpiglo-ji+2
6211	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6212	END DO
6213	DO ji = jpiglo/2+1, jpiglo
6214	ijt = jpiglo-ji+2
6215	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6216	END DO
6217
6218	CASE ( 'U' ) ! U-point
6219	DO ji = 1, jpiglo-1
6220	iju = jpiglo-ji+1
6221	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
6222	END DO
6223	DO ji = jpiglo/2, jpiglo-1
6224	iju = jpiglo-ji+1
6225	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6226	END DO
6227
6228	CASE ( 'V' ) ! V-point
6229	DO ji = 2, jpiglo
6230	ijt = jpiglo-ji+2
6231	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
6232	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
6233	END DO
6234
6235	CASE ( 'F' , 'G' ) ! F-point
6236	DO ji = 1, jpiglo-1
6237	iju = jpiglo-ji+1
6238	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
6239	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
6240	END DO
6241
6242	END SELECT
6243
6244	CASE ( 5, 6 ) ! * North fold F-point pivot
6245
6246	ztab( 1 ,ijpj,jk) = 0._wp
6247	ztab(jpiglo,ijpj,jk) = 0._wp
6248
6249	SELECT CASE ( cd_type )
6250
6251	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6252	DO ji = 1, jpiglo
6253	ijt = jpiglo-ji+1
6254	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
6255	END DO
6256
6257	CASE ( 'U' ) ! U-point
6258	DO ji = 1, jpiglo-1
6259	iju = jpiglo-ji
6260	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
6261	END DO
6262
6263	CASE ( 'V' ) ! V-point
6264	DO ji = 1, jpiglo
6265	ijt = jpiglo-ji+1
6266	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6267	END DO
6268	DO ji = jpiglo/2+1, jpiglo
6269	ijt = jpiglo-ji+1
6270	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6271	END DO
6272
6273	CASE ( 'F' , 'G' ) ! F-point
6274	DO ji = 1, jpiglo-1
6275	iju = jpiglo-ji
6276	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
6277	END DO
6278	DO ji = jpiglo/2+1, jpiglo-1
6279	iju = jpiglo-ji
6280	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6281	END DO
6282
6283	END SELECT
6284
6285	CASE DEFAULT ! * closed
6286
6287	SELECT CASE ( cd_type)
6288
6289	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6290	ztab(:, 1 ,jk) = 0.0_wp
6291	ztab(:,ijpj,jk) = 0.0_wp
6292
6293	CASE ( 'F' ) ! F-point
6294	ztab(:,ijpj,jk) = 0.0_wp
6295
6296	END SELECT
6297
6298	END SELECT
6299
6300	! End of slab
6301	! ===========
6302
6303	END DO
6304	#endif
6305
6306	!! Scatter back to pt3d
6307	DO jr = 1, ndim_rank_north
6308	jproc=nrank_north(jr)+1
6309	ildi=nldit (jproc)
6310	ilei=nleit (jproc)
6311	iilb=pielb(jproc)
6312	!ARPDBG - make loops explicit for performance?
6313	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = &
6314	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk)
6315	END DO
6316
6317	ENDIF ! only done on proc 0 of ncomm_north
6318
6319	CALL prof_region_end(NORTH3DAPPSYMM, iprofStat)
6320
6321	!ARPDBG - could do above on every 'northern' pe and then don't have to
6322	! do scatter below...
6323
6324	CALL prof_region_begin(NORTH3DSCATTER, "North3DScatter", iprofStat)
6325
6326	#ifdef key_mpp_shmem
6327	not done yet in shmem : compiler error
6328	#elif key_mpp_mpi
6329	IF ( npolj /= 0 ) THEN
6330	itaille=nwidthmaxjpkorigijpj
6331	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
6332	znorthloc, itaille,MPI_DOUBLE_PRECISION, &
6333	0,ncomm_north,ierr)
6334	ENDIF
6335	#endif
6336
6337	! put in the last ijpj jlines of pt3d znorthloc while allowing
6338	! for any trimming of domain (see earlier comments and diagram in
6339	! mpp_lbc_north_2d).
6340	#if defined key_z_first
6341	DO ij = jpjglo - jeub + 1, ijpj, 1
6342	jj = nlcj - ijpj + ij
6343	DO jk = 1 , jpk
6344	#else
6345	DO jk = 1 , jpk
6346	DO ij = jpjglo - jeub + 1, ijpj, 1
6347	jj = nlcj - ijpj + ij
6348	#endif
6349	pt3d(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij,jk)
6350	END DO
6351	END DO
6352
6353	CALL prof_region_end(NORTH3DSCATTER, iprofStat)
6354
6355	#endif /* key_mpp_mpi */
6356
6357	END SUBROUTINE mpp_lbc_north_3d
6358
6359	!===================================================================
6360
6361	SUBROUTINE mpp_lbc_north_i3d ( ib3, cd_type, isgn )
6362	!!---------------------------------------------------------------------
6363	!! * routine mpp_lbc_north_3d *
6364	!!
6365	!! ** Purpose :
6366	!! Ensure proper north fold horizontal bondary condition in mpp
6367	!! configuration in case of jpn1 > 1
6368	!!
6369	!! ** Method :
6370	!! Gather the 4 northern lines of the global domain on 1 processor
6371	!! and apply lbc north-fold on this sub array. Then scatter the
6372	!! fold array back to the processors.
6373	!!
6374	!! History :
6375	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
6376	!! from lbc routine
6377	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding
6378	!! rules of lbc_lnk
6379	!!----------------------------------------------------------------------
6380	USE par_oce, ONLY : jpni
6381	USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, &
6382	nwidthmax
6383	USE mapcomm_mod, ONLY : pielb, piesub
6384	USE lib_mpp, ONLY : ctl_stop
6385	IMPLICIT none
6386	!! * Arguments
6387	CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points
6388	! ! = T, U, V, F or W gridp'ts
6389	INTEGER, DIMENSION(:,:,:), INTENT( inout ) :: &
6390	ib3 ! 3D array on which the boundary condition is applied
6391	INTEGER, INTENT( in ) :: &
6392	isgn ! control of the sign change
6393	! ! = -1. , the sign is changed if north fold boundary
6394	! ! = 1. , the sign is kept if north fold boundary
6395
6396	!! * Local declarations
6397	INTEGER :: ijpj
6398	INTEGER :: ijpjm1
6399	INTEGER :: ii, ji, jj, jk, jr, jproc
6400	INTEGER :: ierr
6401	INTEGER :: ildi,ilei,iilb
6402	INTEGER :: ij,ijt,iju
6403	INTEGER :: itaille
6404
6405	!FTRANS ztab :I :I :z
6406	!FTRANS znorthgloio :I :I :z :
6407	!FTRANS znorthloc :I :I :z
6408	INTEGER, DIMENSION(:,:,:) , ALLOCATABLE :: ztab
6409	INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
6410	INTEGER, DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc
6411	!!----------------------------------------------------------------------
6412
6413	! If we get in this routine it s because : North fold condition and
6414	! mpp with more than one proc across i : we deal only with the North
6415	! condition
6416
6417	ijpj = num_nfold_rows
6418	ijpjm1 = ijpj - 1
6419
6420	IF(.not. ALLOCATED(ztab))THEN
6421
6422	ALLOCATE(ztab(jpiglo,ijpj,jpkorig), &
6423	znorthgloio(nwidthmax,ijpj,jpkorig,jpni), &
6424	znorthloc(nwidthmax,ijpj,jpkorig), &
6425	STAT=ierr)
6426	IF(ierr .ne. 0)THEN
6427	CALL ctl_stop('STOP','mpp_lbc_north_i3d: memory allocation failed' )
6428	END IF
6429	END IF
6430
6431	! 0. Sign setting
6432	! ---------------
6433
6434	! put in znorthloc the last ijpj jlines of pt3d while allowing
6435	! for any trimming of domain (see earlier comments and diagram in
6436	! mpp_lbc_north_2d).
6437	znorthloc(:,:,:) = 0 ! because of padding for nwidthmax and domain
6438	! trimming
6439	#if defined key_z_first
6440	DO ij = jpjglo - jeub + 1, ijpj, 1
6441	jj = nlcj - ijpj + ij
6442	DO jk = 1, jpk
6443	#else
6444	DO jk = 1, jpk
6445	DO ij = jpjglo - jeub + 1, ijpj, 1
6446	jj = nlcj - ijpj + ij
6447	#endif
6448	znorthloc(nldi:nlei,ij,jk) = ib3(nldi:nlei,jj,jk)
6449	END DO
6450	END DO
6451
6452
6453	IF (npolj /= 0 ) THEN
6454	! Build in proc 0 of ncomm_north the znorthgloio
6455	znorthgloio(:,:,:,:) = 0
6456
6457	#ifdef key_mpp_shmem
6458	not done : compiler error
6459	#elif defined key_mpp_mpi
6460	! All domains send this number of elements. Narrower domains
6461	! therefore send data padded with zeros
6462	itaille=nwidthmaxjpkijpj
6463	CALL MPI_GATHER(znorthloc, itaille,MPI_INTEGER, &
6464	znorthgloio,itaille,MPI_INTEGER, &
6465	0, ncomm_north, ierr)
6466	#endif
6467
6468	ENDIF
6469
6470	IF (narea == north_root+1 ) THEN
6471	! recover the global north array
6472	ztab(:,:,:) = 0
6473
6474	DO jr = 1, ndim_rank_north
6475	jproc = nrank_north(jr) + 1
6476	ildi = nldit (jproc)
6477	ilei = nleit (jproc)
6478	iilb = pielb(jproc)
6479	! ARPDBG explicit loops for performance?
6480	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = &
6481	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr)
6482	END DO
6483
6484
6485	#if defined key_z_first
6486	! 2. North-Fold boundary conditions
6487	! ----------------------------------
6488
6489	SELECT CASE ( npolj )
6490
6491	CASE ( 3, 4 ) ! * North fold T-point pivot
6492
6493	DO jk = 1, jpk, 1
6494	ztab( 1 ,ijpj,jk) = 0
6495	ztab(jpiglo,ijpj,jk) = 0
6496	END DO
6497
6498	SELECT CASE ( cd_type )
6499
6500	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6501	DO ji = 2, jpiglo
6502	ijt = jpiglo-ji+2
6503	DO jk = 1, jpk, 1
6504	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6505	END DO
6506	END DO
6507	DO ji = jpiglo/2+1, jpiglo
6508	ijt = jpiglo-ji+2
6509	DO jk = 1, jpk, 1
6510	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6511	END DO
6512	END DO
6513
6514	CASE ( 'U' ) ! U-point
6515	DO ji = 1, jpiglo-1
6516	iju = jpiglo-ji+1
6517	DO jk = 1, jpk, 1
6518	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk)
6519	END DO
6520	END DO
6521	DO ji = jpiglo/2, jpiglo-1
6522	iju = jpiglo-ji+1
6523	DO jk = 1, jpk, 1
6524	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6525	END DO
6526	END DO
6527
6528	CASE ( 'V' ) ! V-point
6529	DO ji = 2, jpiglo
6530	ijt = jpiglo-ji+2
6531	DO jk = 1, jpk, 1
6532	ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk)
6533	ztab(ji,ijpj ,jk) = isgn * ztab(ijt,ijpj-3,jk)
6534	END DO
6535	END DO
6536
6537	CASE ( 'F' , 'G' ) ! F-point
6538	DO ji = 1, jpiglo-1
6539	iju = jpiglo-ji+1
6540	DO jk = 1, jpk, 1
6541	ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk)
6542	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-3,jk)
6543	END DO
6544	END DO
6545
6546	END SELECT
6547
6548	CASE ( 5, 6 ) ! * North fold F-point pivot
6549
6550	DO jk = 1, jpk, 1
6551	ztab( 1 ,ijpj,jk) = 0
6552	ztab(jpiglo,ijpj,jk) = 0
6553	END DO
6554
6555	SELECT CASE ( cd_type )
6556
6557	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6558	DO ji = 1, jpiglo
6559	ijt = jpiglo-ji+1
6560	DO jk = 1, jpk, 1
6561	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk)
6562	END DO
6563	END DO
6564
6565	CASE ( 'U' ) ! U-point
6566	DO ji = 1, jpiglo-1
6567	iju = jpiglo-ji
6568	DO jk = 1, jpk, 1
6569	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk)
6570	END DO
6571	END DO
6572
6573	CASE ( 'V' ) ! V-point
6574	DO ji = 1, jpiglo
6575	ijt = jpiglo-ji+1
6576	DO jk = 1, jpk, 1
6577	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6578	END DO
6579	END DO
6580	DO ji = jpiglo/2+1, jpiglo
6581	ijt = jpiglo-ji+1
6582	DO jk = 1, jpk, 1
6583	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6584	END DO
6585	END DO
6586
6587	CASE ( 'F' , 'G' ) ! F-point
6588	DO ji = 1, jpiglo-1
6589	iju = jpiglo-ji
6590	DO jk = 1, jpk, 1
6591	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-2,jk)
6592	END DO
6593	END DO
6594	DO ji = jpiglo/2+1, jpiglo-1
6595	iju = jpiglo-ji
6596	DO jk = 1, jpk, 1
6597	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6598	END DO
6599	END DO
6600
6601	END SELECT
6602
6603	CASE DEFAULT ! * closed
6604
6605	SELECT CASE ( cd_type)
6606
6607	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6608	DO ji = 1, jpiglo, 1
6609	DO jk = 1, jpk, 1
6610	ztab(ji, 1 ,jk) = 0
6611	ztab(ji,ijpj,jk) = 0
6612	END DO
6613	END DO
6614
6615	CASE ( 'F' ) ! F-point
6616	DO ji = 1, jpiglo, 1
6617	DO jk = 1, jpk, 1
6618	ztab(ji,ijpj,jk) = 0
6619	END DO
6620	END DO
6621
6622	END SELECT
6623
6624	END SELECT
6625
6626	! End of slab
6627	! ===========
6628	#else
6629	! Horizontal slab
6630	! ===============
6631
6632	DO jk = 1, jpk
6633
6634
6635	! 2. North-Fold boundary conditions
6636	! ----------------------------------
6637
6638	SELECT CASE ( npolj )
6639
6640	CASE ( 3, 4 ) ! * North fold T-point pivot
6641
6642	ztab( 1 ,ijpj,jk) = 0
6643	ztab(jpiglo,ijpj,jk) = 0
6644
6645	SELECT CASE ( cd_type )
6646
6647	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6648	DO ji = 2, jpiglo
6649	ijt = jpiglo-ji+2
6650	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6651	END DO
6652	DO ji = jpiglo/2+1, jpiglo
6653	ijt = jpiglo-ji+2
6654	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6655	END DO
6656
6657	CASE ( 'U' ) ! U-point
6658	DO ji = 1, jpiglo-1
6659	iju = jpiglo-ji+1
6660	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk)
6661	END DO
6662	DO ji = jpiglo/2, jpiglo-1
6663	iju = jpiglo-ji+1
6664	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6665	END DO
6666
6667	CASE ( 'V' ) ! V-point
6668	DO ji = 2, jpiglo
6669	ijt = jpiglo-ji+2
6670	ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk)
6671	ztab(ji,ijpj ,jk) = isgn * ztab(ijt,ijpj-3,jk)
6672	END DO
6673
6674	CASE ( 'F' , 'G' ) ! F-point
6675	DO ji = 1, jpiglo-1
6676	iju = jpiglo-ji+1
6677	ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk)
6678	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-3,jk)
6679	END DO
6680
6681	END SELECT
6682
6683	CASE ( 5, 6 ) ! * North fold F-point pivot
6684
6685	ztab( 1 ,ijpj,jk) = 0
6686	ztab(jpiglo,ijpj,jk) = 0
6687
6688	SELECT CASE ( cd_type )
6689
6690	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6691	DO ji = 1, jpiglo
6692	ijt = jpiglo-ji+1
6693	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk)
6694	END DO
6695
6696	CASE ( 'U' ) ! U-point
6697	DO ji = 1, jpiglo-1
6698	iju = jpiglo-ji
6699	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk)
6700	END DO
6701
6702	CASE ( 'V' ) ! V-point
6703	DO ji = 1, jpiglo
6704	ijt = jpiglo-ji+1
6705	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6706	END DO
6707	DO ji = jpiglo/2+1, jpiglo
6708	ijt = jpiglo-ji+1
6709	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6710	END DO
6711
6712	CASE ( 'F' , 'G' ) ! F-point
6713	DO ji = 1, jpiglo-1
6714	iju = jpiglo-ji
6715	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-2,jk)
6716	END DO
6717	DO ji = jpiglo/2+1, jpiglo-1
6718	iju = jpiglo-ji
6719	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6720	END DO
6721
6722	END SELECT
6723
6724	CASE DEFAULT ! * closed
6725
6726	SELECT CASE ( cd_type)
6727
6728	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6729	ztab(:, 1 ,jk) = 0
6730	ztab(:,ijpj,jk) = 0
6731
6732	CASE ( 'F' ) ! F-point
6733	ztab(:,ijpj,jk) = 0
6734
6735	END SELECT
6736
6737	END SELECT
6738
6739	! End of slab
6740	! ===========
6741
6742	END DO
6743	#endif
6744
6745	!! Scatter back to pt3d
6746	DO jr = 1, ndim_rank_north
6747	jproc=nrank_north(jr)+1
6748	ildi=nldit (jproc)
6749	ilei=nleit (jproc)
6750	iilb=pielb(jproc)
6751	! DO jk= 1, jpk
6752	! DO jj=1,ijpj
6753	! DO ji=ildi,ilei
6754	! znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk)
6755	! END DO
6756	! END DO
6757	! END DO
6758	! ARPDBG - what about halos?
6759	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = &
6760	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk)
6761	END DO
6762
6763	ENDIF ! only done on proc 0 of ncomm_north
6764
6765	#ifdef key_mpp_shmem
6766	not done yet in shmem : compiler error
6767	#elif key_mpp_mpi
6768	IF ( npolj /= 0 ) THEN
6769	itaille=nwidthmaxjpkijpj
6770	CALL MPI_SCATTER(znorthgloio,itaille,MPI_INTEGER, &
6771	znorthloc, itaille,MPI_INTEGER, &
6772	0, ncomm_north, ierr)
6773	ENDIF
6774	#endif
6775
6776	! put in the last ijpj jlines of pt3d znorthloc while allowing
6777	! for any trimming of domain (see earlier comments and diagram in
6778	! mpp_lbc_north_2d).
6779	#if defined key_z_first
6780	DO ij = jpjglo - jeub + 1, ijpj, 1
6781	jj = nlcj - ijpj + ij
6782	DO ii = nldi, nlei, 1
6783	DO jk = 1 , jpk
6784	#else
6785	DO jk = 1 , jpk
6786	DO ij = jpjglo - jeub + 1, ijpj, 1
6787	jj = nlcj - ijpj + ij
6788	DO ii = nldi, nlei, 1
6789	#endif
6790	ib3(ii,jj,jk)= znorthloc(ii,ij,jk)
6791	END DO
6792	END DO
6793	END DO
6794
6795	END SUBROUTINE mpp_lbc_north_i3d
6796
6797	!====================================================================
6798
6799	END MODULE exchmod
6800
6801	! Copy n contiguous real*8 elements from a to b.
6802	! We expect the compiler to optimise this into a call
6803	! to the system memory copy routine.
6804
6805	SUBROUTINE do_real8_copy( n, a, b )
6806	IMPLICIT none
6807
6808	! arguments
6809	INTEGER, INTENT(in) :: n
6810	REAL*8, dimension(n), INTENT(in ) :: a
6811	REAL*8, DIMENSION(n), INTENT(out) :: b
6812
6813	! local variables
6814	integer :: i
6815
6816	do i=1,n
6817	b(i) = a(i)
6818	end do
6819
6820	END SUBROUTINE do_real8_copy

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

Download in other formats: