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

Last change on this file since 4437 was 4437, checked in by trackstand2, 10 years ago
Trim columns in exchs_generic and init mbkmax in mpp_init3
File size: 230.3 KB

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

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

Download in other formats: