Context Navigation

exchmod.F90 @ 3837

Last change on this file since 3837 was 3837, checked in by trackstand2, 8 years ago
Merge of finiss
File size: 229.9 KB

Line
1	MODULE exchmod
2	USE par_oce, ONLY: wp, jpiglo, jpjglo, jpkdta, jpi, jpj, jpk
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
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	ELSEIF ( PRESENT(ib3) ) THEN
359	#if defined key_z_first
360	kdim1 = SIZE(ib3,dim=1)
361	#else
362	kdim1 = SIZE(ib3,dim=3)
363	#endif
364	ELSEIF ( PRESENT(b2) ) THEN
365	kdim1 = SIZE(b2,dim=2)
366	ELSEIF ( PRESENT(ib2) ) THEN
367	kdim1 = SIZE(ib2,dim=2)
368	ENDIF
369
370	IF( lfillarg ) THEN
371
372	! (nldi,nlej) is only a valid TL corner point if we're not on
373	! an external boundary. If we are then we need nldi+1 if we
374	! have cyclic E-W boundary conditions.
375	ileft = nldi
376	IF( (ilbext .AND. (.NOT. trimmed(widx,narea))) .AND. cyclic_bc) &
377	ileft = ileft + 1
378
379	iright = nlei
380	IF( (iubext .AND. (.NOT. trimmed(eidx,narea))) .AND. cyclic_bc) &
381	iright = iright - 1
382
383	IF ( PRESENT(b2) ) THEN
384	DO jj = 1, jprecj, 1 ! only fill extra allows last line
385	b2(nldi:nlei , jj) = b2(nldi:nlei, nldj)
386	b2(1:jpreci , jj) = b2(ileft, nldj) ! Bottom-left corner points
387	b2(nlci:jpi, jj) = b2(iright, nldj) ! Bottom-right corner points
388	END DO
389
390	DO jj = nlej+1, jpj, 1 ! only fill extra allows last line
391	b2(nldi:nlei , jj) = b2(nldi:nlei, nlej)
392	b2(1:jpreci , jj) = b2(ileft, nlej) ! Top-left corner points
393	b2(nlci:jpi, jj) = b2(iright, nlej)! Top-right corner points
394	END DO
395
396	DO jj = nldj,nlej,1 ! Left halo columns
397	b2(1: jpreci , jj ) = b2(ileft, jj )
398	END DO
399
400	DO jj = nldj, nlej, 1 ! Right halo columns
401	b2(nlci:jpi , jj ) = b2(iright, jj )
402	END DO
403
404	ELSE IF ( PRESENT(ib2) ) THEN
405
406	DO jj = 1, jprecj ! only fill extra allows last line
407	ib2(nldi:nlei , jj) = ib2(nldi:nlei, nldj)
408	ib2( 1:jpreci, jj) = ib2(ileft , nldj) ! Bottom-left corner points
409	ib2(nlci:jpi , jj) = ib2(iright , nldj) ! Bottom-right corner points
410	END DO
411
412	DO jj = nlej+1, jpj
413	ib2(nldi:nlei, jj) = ib2(nldi:nlei, nlej)
414	ib2(1:jpreci , jj) = ib2(ileft , nlej) ! Top-left corner points
415	ib2(nlci:jpi , jj) = ib2(iright , nlej) ! Top-right corner points
416	END DO
417
418	DO jj = nldj,nlej,1 ! West-most columns
419	ib2(1:jpreci, jj) = ib2(ileft, jj)
420	END DO
421
422	DO jj = nldj, nlej, 1 ! East-most columns
423	ib2(nlci:jpi, jj) = ib2(iright, jj)
424	END DO
425
426	ELSE IF ( PRESENT(b3) ) THEN
427
428	#if defined key_z_first
429	DO jj = 1, jprecj, 1 ! Bottom rows
430	DO ii = nldi, nlei, 1
431	b3(ii, jj, 1:kdim1) = b3(ii, nldj, 1:kdim1) ! Bottom rows
432	END DO
433	DO ii = 1, jpreci, 1
434	b3(ii, jj, 1:kdim1) = b3(ileft ,nldj,1:kdim1) ! Bottom-L corner
435	END DO
436	DO ii = nlci, jpi, 1
437	b3(ii, jj, 1:kdim1) = b3(iright ,nldj,1:kdim1) ! Bottom-R corner
438	END DO
439	END DO
440
441	DO jj = nlej+1, jpj, 1 ! Top rows
442	DO ii = 1, jpreci, 1
443	b3(ii, jj,1:kdim1) = b3(ileft,nlej,1:kdim1) ! Top-L corner pts
444	END DO
445	DO ii = nldi, nlei, 1
446	b3(ii, jj,1:kdim1) = b3(ii,nlej,1:kdim1) ! Top rows
447	END DO
448	DO ii = nlci, jpi, 1
449	b3(ii , jj,1:kdim1) = b3(iright,nlej,1:kdim1) ! Top-R corner pts
450	END DO
451	END DO
452
453	DO jj = nldj, nlej, 1 ! E-most columns
454	DO ii = nlci, jpi, 1
455	b3(ii, jj, 1:kdim1) = b3(iright, jj, 1:kdim1)
456	END DO
457	END DO
458
459	DO jj = nldj, nlej, 1 ! W-most columns
460	DO ii = 1, jpreci, 1
461	b3(ii, jj, 1:kdim1) = b3(ileft, jj, 1:kdim1)
462	END DO
463	END DO
464	#else
465	jk_loop: DO jk = 1,kdim1,1
466
467	DO jj = 1, jprecj, 1 ! Bottom rows
468	b3(nldi:nlei, jj, jk) = b3(nldi:nlei,nldj,jk) ! Bottom rows
469	b3(1:jpreci , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner
470	b3(nlci:jpi , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner
471	END DO
472
473	DO jj = nlej+1, jpj, 1 ! Top rows
474	b3(nldi:nlei, jj,jk) = b3(nldi:nlei,nlej,jk) ! Top rows
475	b3(1:jpreci , jj,jk) = b3(ileft ,nlej,jk) ! Top-L corner pts
476	b3(nlci:jpi , jj,jk) = b3(iright ,nlej,jk) ! Top-R corner pts
477	END DO
478
479	DO jj = nldj, nlej, 1 ! E-most columns
480	b3(nlci:jpi, jj, jk) = b3(iright, jj, jk)
481	END DO
482
483	DO jj = nldj, nlej, 1 ! W-most columns
484	b3(1:jpreci, jj, jk) = b3(ileft, jj, jk)
485	END DO
486
487	END DO jk_loop
488	#endif
489
490	ELSE IF ( PRESENT(ib3) ) THEN
491
492	#if defined key_z_first
493	! ARPDBG - do I need to make ii loops explicit and appropriately ordered?
494	DO jj = 1,jprecj ! Bottom rows
495	DO jk = 1,kdim1,1
496	ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
497	ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner
498	ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner
499	END DO
500	END DO
501
502	DO jj = nlej+1, jpj ! Top rows
503	DO jk = 1,kdim1,1
504	ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
505	ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts
506	ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts
507	END DO
508	END DO
509
510	DO jj = nldj,nlej, 1 ! E-most columns
511	DO jk = 1,kdim1,1
512	ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
513	END DO
514	END DO
515
516	DO jj = nldj,nlej,1 ! W-most columns
517	DO jk = 1,kdim1,1
518	ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
519	END DO
520	END DO
521	#else
522	DO jk = 1,kdim1,1
523
524	DO jj = 1,jprecj ! Bottom rows
525	ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
526	ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner
527	ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner
528	END DO
529
530	DO jj = nlej+1, jpj ! Top rows
531	ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
532	ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts
533	ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts
534	END DO
535
536	DO jj = nldj,nlej, 1 ! E-most columns
537	ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
538	END DO
539
540	DO jj = nldj,nlej,1 ! W-most columns
541	ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
542	END DO
543
544	END DO
545	#endif
546
547	END IF
548
549	ELSE ! lfillarg is .FALSE. - standard closed or cyclic treatment
550
551	! ! East-West boundaries
552	! ! ====================
553	! nbondi == 2 when a single sub-domain spans the whole width
554	! of the global domain
555	IF( nbondi == 2 .AND. & ! Cyclic east-west
556	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
557
558	IF ( PRESENT(b2) ) THEN
559
560	b2( 1 ,:) = b2(jpim1,:) ! Set west halo to last valid east value
561	b2(jpi,:) = b2(nldi ,:) ! east halo to first valid west value
562	ELSE IF ( PRESENT(ib2) ) THEN
563
564	ib2( 1 ,:) = ib2(jpim1,:)
565	ib2(jpi,:) = ib2(nldi ,:)
566	ELSE IF ( PRESENT(b3) ) THEN
567
568	#if defined key_z_first
569	DO jj = 1,jpj,1
570	DO jk = 1,jpk,1
571	b3( 1, jj, jk) = b3(jpim1, jj, jk)
572	b3(jpi,jj, jk) = b3( 2, jj, jk)
573	END DO
574	END DO
575	#else
576	b3( 1, :, :) = b3(jpim1, :, :)
577	b3(jpi,:, :) = b3( 2, :, :)
578	#endif
579	ELSE IF ( PRESENT(ib3) ) THEN
580
581	ib3( 1, :, :) = ib3(jpim1, :, :)
582	ib3(jpi,:, :) = ib3( 2, :, :)
583	END IF
584
585	ELSE ! ... closed East-West boundaries
586
587	IF( lzeroarg )THEN
588
589	IF ( PRESENT(b2) ) THEN
590	SELECT CASE ( cd_type )
591	CASE ( 'T', 'U', 'V', 'W' , 'I' )
592	b2(1:jpreci , :) = zland ! Western halo
593	b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo
594	CASE ( 'F' )
595	b2(nlci-jpreci+1:jpi, :) = zland ! Eastern halo
596	END SELECT
597	ELSE IF ( PRESENT(ib2) ) THEN
598	SELECT CASE ( cd_type )
599	CASE ( 'T', 'U', 'V', 'W' , 'I' )
600	ib2(1:jpreci , :) = iland ! Western halo
601	ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo
602	CASE ( 'F' )
603	ib2(nlci-jpreci+1:jpi, :) = iland ! Eastern halo
604	END SELECT
605	ELSE IF ( PRESENT(b3) ) THEN
606	SELECT CASE ( cd_type )
607	CASE ( 'T', 'U', 'V', 'W' )
608	#if defined key_z_first
609	DO jj=1,jpj,1
610	DO ji=1,jpreci,1
611	DO jk=1,jpk,1
612	b3(ji, jj, jk) = zland
613	END DO
614	END DO
615	DO ji=nlci-jpreci+1,jpi,1
616	DO jk=1,jpk,1
617	b3(ji, jj, jk) = zland
618	END DO
619	END DO
620	END DO
621	#else
622	b3(1:jpreci , :, :) = zland
623	b3(nlci-jpreci+1:jpi, :, :) = zland
624	#endif
625	CASE ( 'F' )
626	#if defined key_z_first
627	DO jj=1,jpj,1
628	DO ji = nlci-jpreci+1,jpi,1
629	DO jk = 1,jpk,1
630	b3(ji, jj, jk) = zland
631	END DO
632	END DO
633	END DO
634	#else
635	b3(nlci-jpreci+1:jpi, :, :) = zland
636	#endif
637	END SELECT
638	ELSE IF ( PRESENT(ib3) ) THEN
639	SELECT CASE ( cd_type )
640	CASE ( 'T', 'U', 'V', 'W' )
641	ib3(1:jpreci , :, :) = iland
642	ib3(nlci-jpreci+1:jpi, :, :) = iland
643	CASE ( 'F' )
644	ib3(nlci-jpreci+1:jpi, :, :) = iland
645	END SELECT
646	END IF
647
648	END IF ! lzeroarg
649
650	END IF
651
652	IF( lzeroarg )THEN
653
654	! ! North-South boundaries (always closed)
655	! ! ======================
656	IF ( PRESENT(b2) ) THEN
657	SELECT CASE ( cd_type )
658	CASE ( 'T', 'U', 'V', 'W' , 'I' )
659	!b2(:,1:nldj-1 ) = zland
660	! Below is what is done in original lib_mpp.F90
661	b2(:,1:jprecj ) = zland
662	b2(:,nlcj-jprecj+1:jpj) = zland
663	CASE ( 'F' )
664	b2(:,nlcj-jprecj+1:jpj) = zland
665	END SELECT
666	ELSE IF ( PRESENT(ib2) ) THEN
667	SELECT CASE ( cd_type )
668	CASE ( 'T', 'U', 'V', 'W' , 'I' )
669	ib2(:,1:jprecj ) = iland
670	ib2(:,nlcj-jprecj+1:jpj) = iland
671	CASE ( 'F' )
672	ib2(:,nlcj-jprecj+1:jpj) = iland
673	END SELECT
674	ELSE IF ( PRESENT(b3) ) THEN
675	SELECT CASE ( cd_type )
676	CASE ( 'T', 'U', 'V', 'W' )
677	#if defined key_z_first
678	DO jj=1,jprecj,1
679	DO ji=1,jpi,1
680	DO jk = 1,jpk,1
681	b3(ji, jj, jk) = zland
682	END DO
683	END DO
684	END DO
685	DO jj=nlcj-jprecj+1,jpj,1
686	DO ji=1,jpi,1
687	DO jk = 1,jpk,1
688	b3(ji, jj, jk) = zland
689	END DO
690	END DO
691	END DO
692	#else
693	b3(:, 1:jprecj , :) = zland
694	b3(:, nlcj-jprecj+1:jpj, :) = zland
695	#endif
696	CASE ( 'F' )
697	#if defined key_z_first
698	DO jj=nlcj-jprecj+1,jpj,1
699	DO ji=1,jpi,1
700	DO jk = 1,jpk,1
701	b3(ji, jj, jk) = zland
702	END DO
703	END DO
704	END DO
705	#else
706	b3(:, nlcj-jprecj+1:jpj, :) = zland
707	#endif
708	END SELECT
709	ELSE IF ( PRESENT(ib3) ) THEN
710	SELECT CASE ( cd_type )
711	CASE ( 'T', 'U', 'V', 'W' )
712	ib3(:, 1:jprecj , :) = iland
713	ib3(:, nlcj-jprecj+1:jpj, :) = iland
714	CASE ( 'F' )
715	ib3(:, nlcj-jprecj+1:jpj, :) = iland
716	END SELECT
717	END IF
718
719	END IF ! lzeroarg
720
721	END IF ! lfillarg
722
723	! Do East-West and North-South exchanges
724	CALL exchs_generic ( b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, &
725	nhexch=nhexch, handle=itag, &
726	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
727	cd_type=cd_type, lfill=lfillarg)
728
729	!CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, &
730	! nhexch=nhexch, handle=itag, &
731	! comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 )
732
733
734	! Apply north-fold condition
735	IF(.not. lfillarg)THEN
736	IF(PRESENT(b2))THEN
737	CALL apply_north_fold(b2, isgnarg, cd_type)
738	ELSE IF(PRESENT(ib2))THEN
739	CALL apply_north_fold(ib2, isgnarg, cd_type)
740	ELSE IF(PRESENT(b3))THEN
741	CALL apply_north_fold(b3, isgnarg, cd_type)
742	ELSE IF(PRESENT(ib3))THEN
743	CALL apply_north_fold(ib3, isgnarg, cd_type)
744	ELSE
745	STOP 'ARPDBG: ERROR - no matching version of apply_north_fold!'
746	END IF
747
748
749	!WRITE (,) 'ARPDBG: bound_exch_generic: npolj = ',npolj
750	! We only need to repeat the East and West halo swap if there
751	! IS a north-fold in the configuration.
752	!SELECT CASE (npolj)
753
754	!CASE ( 3, 4, 5, 6 )
755	IF(ndim_rank_north > 0)THEN
756
757	! Update East and West halos as required - no data sent north
758	! as it's only the northern-most PEs that have been affected
759	! by the north-fold condition.
760	! ARPDBG - inefficient since all PEs do halo swap and only
761	! those affected by the north fold actually need to - can
762	! this be done within apply_north_fold?
763	CALL exchs_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3, nhalo=nhalo, &
764	nhexch=nhexch, handle=itag, &
765	comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
766	cd_type=cd_type, lfill=lfillarg)
767
768	!CALL exchr_generic (b2=b2,ib2=ib2,b3=b3,ib3=ib3,nhalo=nhalo, &
769	! nhexch=nhexch, handle=itag, &
770	! comm1=Iplus,comm2=Iminus,comm3=NONE,comm4=NONE)
771	! comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4 )
772	END IF ! ndim_rank_north > 0
773	!END SELECT ! npolj
774
775	END IF
776
777	! CALL prof_region_end(ARPCOMMS, iprofStat)
778	! CALL timing_stop('bound_exch_generic','section')
779
780	END SUBROUTINE bound_exch_generic
781
782	! ------------------------------------------------------------------------
783
784	SUBROUTINE bound_exch_list ()
785	USE par_oce, ONLY: wp, jpreci, jprecj, jpim1
786	USE dom_oce, ONLY: nlci, nlcj, nldi, nlei, nldj, nlej, &
787	nperio, nbondi
788	USE mapcomm_mod, ONLY: Iminus, Iplus, NONE, ilbext, iubext, cyclic_bc
789	IMPLICIT none
790	! Local arguments
791	INTEGER :: ii, jj, jk, ifield ! Loop indices
792	INTEGER :: ileft, iright ! First and last x-coord of internal points
793	INTEGER :: kdim1
794	INTEGER :: nfields
795	!FTRANS b3 :I :I :z
796	!FTRANS ib3 :I :I :z
797	INTEGER, DIMENSION(:,:), POINTER :: ib2
798	INTEGER, DIMENSION(:,:,:), POINTER :: ib3
799	REAL, DIMENSION(:,:), POINTER :: b2
800	REAL, DIMENSION(:,:,:), POINTER :: b3
801	!!----------------------------------------------------------------------
802
803	#if ! defined key_mpp_rkpart
804	RETURN
805	#endif
806
807	NULLIFY(ib2, ib3, b2, b3)
808
809	nfields = nextFreeExchItem - 1
810
811	CALL prof_region_begin(ARPLISTCOMMS, "ListComms", iprofStat)
812
813	DO ifield=1, nfields, 1
814
815	! Find out the size of 3rd dimension of the array
816
817	kdim1 = 1
818	IF ( ASSOCIATED(exch_list(ifield)%r3dptr) ) THEN
819	b3 => exch_list(ifield)%r3dptr
820	#if defined key_z_first
821	kdim1 = SIZE(b3,dim=1)
822	#else
823	kdim1 = SIZE(b3,dim=3)
824	#endif
825	ELSEIF ( ASSOCIATED(exch_list(ifield)%i3dptr) ) THEN
826	ib3 => exch_list(ifield)%i3dptr
827	#if defined key_z_first
828	kdim1 = SIZE(ib3,dim=1)
829	#else
830	kdim1 = SIZE(ib3,dim=3)
831	#endif
832	ELSEIF ( ASSOCIATED(exch_list(ifield)%r2dptr) ) THEN
833	b2 => exch_list(ifield)%r2dptr
834	kdim1 = SIZE(b2,dim=2)
835	ELSEIF ( ASSOCIATED(exch_list(ifield)%i2dptr) ) THEN
836	ib2 => exch_list(ifield)%i2dptr
837	kdim1 = SIZE(ib2,dim=2)
838	ENDIF
839
840	IF( exch_list(ifield)%lfill ) THEN
841
842	! (nldi,nlej) is only a valid TL corner point if we're not on an
843	! external boundary. If we are AND we have cyclic E-W boundary
844	! conditions then we need nldi+1.
845	ileft = nldi
846	IF(ilbext .AND. cyclic_bc)ileft = ileft + 1
847
848	iright = nlei
849	IF(iubext .AND. cyclic_bc)iright = iright - 1
850
851	IF ( ASSOCIATED(b2) ) THEN
852
853	DO jj = 1, jprecj, 1 ! only fill extra allows last line
854	b2(nldi:nlei , jj) = b2(nldi:nlei, nldj)
855	b2(1:jpreci , jj) = b2(ileft, nldj) ! Bottom-left corner points
856	b2(nlci:jpi, jj) = b2(iright, nldj) ! Bottom-right corner points
857	END DO
858
859	DO jj = nlej+1, jpj, 1 ! only fill extra allows last line
860	b2(nldi:nlei , jj) = b2(nldi:nlei, nlej)
861	b2(1:jpreci , jj) = b2(ileft, nlej) ! Top-left corner points
862	b2(nlci:jpi, jj) = b2(iright, nlej)! Top-right corner points
863	END DO
864
865	DO jj = nldj,nlej,1 ! Left halo columns
866	b2(1: jpreci , jj ) = b2(ileft, jj )
867	END DO
868
869	DO jj = nldj, nlej, 1 ! Right halo columns
870	b2(nlci:jpi , jj ) = b2(iright, jj )
871	END DO
872
873	ELSE IF ( ASSOCIATED(ib2) ) THEN
874
875	DO jj = 1, jprecj ! only fill extra allows last line
876	ib2(nldi:nlei , jj) = ib2(nldi:nlei, nldj)
877	ib2( 1:jpreci, jj) = ib2(ileft , nldj) ! Bottom-left corner points
878	ib2(nlci:jpi , jj) = ib2(iright , nldj) ! Bottom-right corner points
879	END DO
880
881	DO jj = nlej+1, jpj
882	ib2(nldi:nlei, jj) = ib2(nldi:nlei, nlej)
883	ib2(1:jpreci , jj) = ib2(ileft , nlej) ! Top-left corner points
884	ib2(nlci:jpi , jj) = ib2(iright , nlej) ! Top-right corner points
885	END DO
886
887	DO jj = nldj,nlej,1 ! West-most columns
888	ib2(1:jpreci, jj) = ib2(ileft, jj)
889	END DO
890
891	DO jj = nldj, nlej, 1 ! East-most columns
892	ib2(nlci:jpi, jj) = ib2(iright, jj)
893	END DO
894
895	ELSE IF ( ASSOCIATED(b3) ) THEN
896
897	#if defined key_z_first
898	DO jj = 1, jprecj, 1 ! Bottom rows
899	DO ii = nldi, nlei, 1
900	DO jk = 1,kdim1,1
901	b3(ii, jj, jk) = b3(ii,nldj,jk) ! Bottom rows
902	END DO
903	END DO
904	DO ii = 1, jpreci, 1
905	DO jk = 1,kdim1,1
906	b3(ii , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner
907	END DO
908	END DO
909	DO ii = nlci, jpi, 1
910	DO jk = 1,kdim1,1
911	b3(ii , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner
912	END DO
913	END DO
914	END DO
915
916	DO jj = nlej+1, jpj, 1 ! Top rows
917	DO ii = nldi, nlei, 1
918	DO jk = 1,kdim1,1
919	b3(ii, jj,jk) = b3(ii,nlej,jk) ! Top rows
920	END DO
921	END DO
922	DO ii = 1, jpreci, 1
923	DO jk = 1,kdim1,1
924	b3(ii, jj,jk) = b3(ileft,nlej,jk) ! Top-L corner pts
925	END DO
926	END DO
927	DO ii = nlci, jpi, 1
928	DO jk = 1,kdim1,1
929	b3(ii,jj,jk) = b3(iright,nlej,jk) ! Top-R corner pts
930	END DO
931	END DO
932	END DO
933
934	DO jj = nldj, nlej, 1
935	! E-most columns
936	DO ii = nlci, jpi, 1
937	DO jk = 1,kdim1,1
938	b3(ii, jj, jk) = b3(iright, jj, jk)
939	END DO
940	END DO
941
942	! W-most columns
943	DO ii = 1, jpreci, 1
944	DO jk = 1,kdim1,1
945	b3(ii, jj, jk) = b3(ileft, jj, jk)
946	END DO
947	END DO
948	END DO
949	#else
950	jk_loop: DO jk = 1,kdim1,1
951
952	DO jj = 1, jprecj, 1 ! Bottom rows
953	b3(nldi:nlei, jj, jk) = b3(nldi:nlei,nldj,jk) ! Bottom rows
954	b3(1:jpreci , jj, jk) = b3(ileft ,nldj,jk) ! Bottom-L corner
955	b3(nlci:jpi , jj, jk) = b3(iright ,nldj,jk) ! Bottom-R corner
956	END DO
957
958	DO jj = nlej+1, jpj, 1 ! Top rows
959	b3(nldi:nlei, jj,jk) = b3(nldi:nlei,nlej,jk) ! Top rows
960	b3(1:jpreci , jj,jk) = b3(ileft ,nlej,jk) ! Top-L corner pts
961	b3(nlci:jpi , jj,jk) = b3(iright ,nlej,jk) ! Top-R corner pts
962	END DO
963
964	DO jj = nldj, nlej, 1 ! E-most columns
965	b3(nlci:jpi, jj, jk) = b3(iright, jj, jk)
966	END DO
967
968	DO jj = nldj, nlej, 1 ! W-most columns
969	b3(1:jpreci, jj, jk) = b3(ileft, jj, jk)
970	END DO
971
972	END DO jk_loop
973	#endif
974
975	ELSE IF ( ASSOCIATED(ib3) ) THEN
976	#if defined key_z_first
977	! ARPDBG need make loops over i explicit for optimum performance
978	DO jj = 1,jprecj ! Bottom rows
979	DO jk = 1,kdim1,1
980	ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
981	ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner
982	ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner
983	END DO
984	END DO
985
986	DO jj = nlej+1, jpj ! Top rows
987	DO jk = 1,kdim1,1
988	ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
989	ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts
990	ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts
991	END DO
992	END DO
993
994	DO jj = nldj,nlej, 1 ! E-most columns
995	DO jk = 1,kdim1,1
996	ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
997	END DO
998	END DO
999
1000	DO jj = nldj,nlej,1 ! W-most columns
1001	DO jk = 1,kdim1,1
1002	ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
1003	END DO
1004	END DO
1005	#else
1006	DO jk = 1,kdim1,1
1007
1008	DO jj = 1,jprecj ! Bottom rows
1009	ib3(nldi:nlei, jj, jk) = ib3(nldi:nlei,nldj,jk) ! Bottom rows
1010	ib3(1:jpreci, jj, jk) = ib3(ileft ,nldj,jk) ! Bottom-L corner
1011	ib3(nlci:jpi,jj, jk) = ib3(iright ,nldj,jk) ! Bottom-R corner
1012	END DO
1013
1014	DO jj = nlej+1, jpj ! Top rows
1015	ib3(nldi:nlei,jj,jk) = ib3(nldi:nlei,nlej,jk) ! Top rows
1016	ib3(1:jpreci ,jj,jk) = ib3(ileft ,nlej,jk) ! Top-L corner pts
1017	ib3(nlci:jpi ,jj,jk) = ib3(iright ,nlej,jk) ! Top-R corner pts
1018	END DO
1019
1020	DO jj = nldj,nlej, 1 ! E-most columns
1021	ib3(nlci:jpi, jj, jk) = ib3(iright, jj, jk)
1022	END DO
1023
1024	DO jj = nldj,nlej,1 ! W-most columns
1025	ib3(1:jpreci, jj, jk) = ib3(ileft, jj, jk)
1026	END DO
1027
1028	END DO
1029	#endif
1030
1031	END IF
1032
1033	ELSE ! lfill is .FALSE. for this field
1034
1035	! ! East-West boundaries
1036	! ! ====================
1037	IF( nbondi == 2 .AND. & ! Cyclic east-west
1038	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1039
1040	IF ( ASSOCIATED(b2) ) THEN
1041
1042	b2( 1 ,:) = b2(jpim1,:) ! Set west halo to last valid east value
1043	b2(jpi,:) = b2(nldi ,:) ! east halo to first valid west value
1044	ELSE IF ( ASSOCIATED(ib2) ) THEN
1045
1046	ib2( 1 ,:) = ib2(jpim1,:)
1047	ib2(jpi,:) = ib2(nldi ,:)
1048	ELSE IF ( ASSOCIATED(b3) ) THEN
1049
1050	b3( 1, :, :) = b3(jpim1, :, :)
1051	b3(jpi,:, :) = b3( 2, :, :)
1052	ELSE IF ( ASSOCIATED(ib3) ) THEN
1053
1054	ib3( 1, :, :) = ib3(jpim1, :, :)
1055	ib3(jpi,:, :) = ib3( 2, :, :)
1056	END IF
1057
1058	ELSE ! ... closed
1059
1060	END IF
1061
1062	! ! North-South boundaries
1063	! ! ======================
1064	IF ( ASSOCIATED(b2) ) THEN
1065	SELECT CASE ( exch_list(ifield)%grid )
1066	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1067	b2(:,1:jprecj ) = 0.0_wp
1068	b2(:,nlcj-jprecj+1:jpj) = 0.0_wp
1069	CASE ( 'F' )
1070	b2(:,nlcj-jprecj+1:jpj) = 0.0_wp
1071	END SELECT
1072	ELSE IF ( ASSOCIATED(ib2) ) THEN
1073	SELECT CASE ( exch_list(ifield)%grid )
1074	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1075	ib2(:,1:jprecj ) = 0
1076	ib2(:,nlcj-jprecj+1:jpj) = 0
1077	CASE ( 'F' )
1078	ib2(:,nlcj-jprecj+1:jpj) = 0
1079	END SELECT
1080	ELSE IF ( ASSOCIATED(b3) ) THEN
1081	SELECT CASE ( exch_list(ifield)%grid )
1082	CASE ( 'T', 'U', 'V', 'W' )
1083	b3(:, 1:jprecj , :) = 0.0_wp
1084	b3(:, nlcj-jprecj+1:jpj, :) = 0.0_wp
1085	CASE ( 'F' )
1086	b3(:, nlcj-jprecj+1:jpj, :) = 0.0_wp
1087	END SELECT
1088	ELSE IF ( ASSOCIATED(ib3) ) THEN
1089	SELECT CASE ( exch_list(ifield)%grid )
1090	CASE ( 'T', 'U', 'V', 'W' )
1091	ib3(:, 1:jprecj , :) = 0
1092	ib3(:, nlcj-jprecj+1:jpj, :) = 0
1093	CASE ( 'F' )
1094	ib3(:, nlcj-jprecj+1:jpj, :) = 0
1095	END SELECT
1096	END IF
1097
1098	END IF ! lfillarg
1099
1100	END DO ! loop over fields
1101
1102	! Do East-West and North-South exchanges
1103	CALL exchs_generic_list ( exch_list, nfields )
1104
1105	! Apply north-fold condition to those fields that need it and delete the
1106	! others from the list
1107	CALL apply_north_fold_list(exch_list, nfields)
1108
1109	! Update East and West halos on those fields that have just had the
1110	! north-fold condition applied (will be the only ones left in the list
1111	! as the others are removed within apply_north_fold_list.)
1112	! ARPDBG - inefficient - can this be done within apply_north_fold?
1113	CALL exchs_generic_list (exch_list, nfields)
1114
1115	CALL prof_region_end(ARPLISTCOMMS, iprofStat)
1116
1117	DO ifield=1,nfields,1
1118	NULLIFY(exch_list(ifield)%r2dptr, exch_list(ifield)%r3dptr, &
1119	exch_list(ifield)%i2dptr, exch_list(ifield)%i3dptr)
1120	END DO
1121
1122	nextFreeExchItem = 1
1123
1124	END SUBROUTINE bound_exch_list
1125
1126	!=========================================================================
1127
1128	SUBROUTINE apply_north_fold_list(list, nfields)
1129	USE par_oce, ONLY: wp, jpni, jpk
1130	USE dom_oce, ONLY: npolj
1131	IMPLICIT none
1132	! Subroutine arguments.
1133	TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
1134	INTEGER, INTENT(in) :: nfields
1135	! Local variables
1136	INTEGER :: ifield
1137	INTEGER :: icount
1138
1139	icount = 0
1140
1141	DO ifield = 1, nfields, 1
1142
1143	IF(list(ifield)%lfill)THEN
1144	! This field doesn't have north-fold condition applied to it
1145	! so wipe its entry...
1146	CALL wipe_exch(list(ifield))
1147	icount = icount + 1
1148	! ...and don't do any more with it
1149	CYCLE
1150	END IF
1151
1152	END DO
1153
1154	! Check whether any of the fields need the north-fold condition
1155	! applied
1156	IF(icount .eq. nfields)RETURN
1157
1158	! Treatment without exchange (jpni odd)
1159
1160	SELECT CASE ( jpni )
1161
1162	CASE ( 1 ) ! only one proc along i, no mpp exchange
1163
1164	DO ifield = 1, nfields, 1
1165
1166	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
1167
1168	CALL apply_north_fold_jpni1_2dr(list(ifield))
1169
1170	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
1171
1172	CALL apply_north_fold_jpni1_3dr(list(ifield))
1173
1174	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
1175
1176	CALL apply_north_fold_jpni1_2di(list(ifield))
1177
1178	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
1179
1180	CALL apply_north_fold_jpni1_3di(list(ifield))
1181
1182	END IF
1183
1184
1185	END DO ! Loop over fields
1186
1187	CASE DEFAULT ! more than 1 proc along I
1188
1189	DO ifield = 1, nfields, 1
1190	IF( npolj /= 0 .AND. do_nfold )THEN ! only for northern procs.
1191
1192	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
1193
1194	CALL mpp_lbc_north( list(ifield)%r2dptr, list(ifield)%grid, &
1195	REAL(list(ifield)%isgn,wp) )
1196	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
1197	CALL mpp_lbc_north( list(ifield)%r3dptr, list(ifield)%grid, &
1198	REAL(list(ifield)%isgn,wp) )
1199	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
1200	CALL mpp_lbc_north( list(ifield)%i2dptr, list(ifield)%grid, &
1201	list(ifield)%isgn )
1202	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
1203	CALL mpp_lbc_north( list(ifield)%i3dptr, list(ifield)%grid, &
1204	list(ifield)%isgn )
1205	END IF
1206
1207	END IF
1208	END DO
1209
1210	!!$ IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north_list( list, nfields ) ! only for northern procs.
1211
1212	END SELECT ! jpni
1213
1214	END SUBROUTINE apply_north_fold_list
1215
1216	!=========================================================================
1217
1218	SUBROUTINE apply_north_fold_jpni1_2dr(item)
1219	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1220	USE lib_mpp, ONLY: ctl_stop
1221	IMPLICIT None
1222	TYPE (exch_item), INTENT(inout) :: item
1223	! Locals
1224	INTEGER :: iloc, ji, ijt, iju
1225	REAL(wp) :: psgn
1226	REAL(wp), DIMENSION(:,:), POINTER :: b2
1227
1228	!#if defined key_z_first
1229	! CALL ctl_stop('STOP', &
1230	! 'apply_north_fold_jpni1_2dr: key_z_first not implemented for north fold')
1231	! RETURN
1232	!#endif
1233
1234	psgn = REAL(item%isgn, wp)
1235	b2 => item%r2dptr
1236
1237	SELECT CASE ( npolj )
1238
1239	CASE ( 3 , 4 ) ! T pivot
1240	iloc = jpiglo - 2 * ( nimpp - 1 )
1241
1242	SELECT CASE ( item%grid )
1243
1244	CASE ( 'T' , 'S', 'W' )
1245	DO ji = 2, nlci
1246	ijt=iloc-ji+2
1247	b2(ji,nlcj) = psgn * b2(ijt,nlcj-2)
1248	END DO
1249	DO ji = nlci/2+1, nlci
1250	ijt=iloc-ji+2
1251	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1252	END DO
1253
1254	CASE ( 'U' )
1255	DO ji = 1, nlci-1
1256	iju=iloc-ji+1
1257	b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1258	END DO
1259	DO ji = nlci/2, nlci-1
1260	iju=iloc-ji+1
1261	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1262	END DO
1263
1264	CASE ( 'V' )
1265	DO ji = 2, nlci
1266	ijt=iloc-ji+2
1267	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-2)
1268	b2(ji,nlcj ) = psgn * b2(ijt,nlcj-3)
1269	END DO
1270
1271	CASE ( 'F', 'G' )
1272	DO ji = 1, nlci-1
1273	iju=iloc-ji+1
1274	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-2)
1275	b2(ji,nlcj ) = psgn * b2(iju,nlcj-3)
1276	END DO
1277
1278	CASE ( 'I' ) ! ice U-V point
1279	b2(2,nlcj) = psgn * b2(3,nlcj-1)
1280	DO ji = 3, nlci
1281	iju = iloc - ji + 3
1282	b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1283	END DO
1284
1285	END SELECT
1286
1287	CASE ( 5 , 6 ) ! F pivot
1288	iloc=jpiglo-2*(nimpp-1)
1289
1290	SELECT CASE (item%grid)
1291
1292	CASE ( 'T', 'S', 'W' )
1293	DO ji = 1, nlci
1294	ijt=iloc-ji+1
1295	b2(ji,nlcj) = psgn * b2(ijt,nlcj-1)
1296	END DO
1297
1298	CASE ( 'U' )
1299	DO ji = 1, nlci-1
1300	iju=iloc-ji
1301	b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1302	END DO
1303
1304	CASE ( 'V' )
1305	DO ji = 1, nlci
1306	ijt=iloc-ji+1
1307	b2(ji,nlcj ) = psgn * b2(ijt,nlcj-2)
1308	END DO
1309	DO ji = nlci/2+1, nlci
1310	ijt=iloc-ji+1
1311	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1312	END DO
1313
1314	CASE ( 'F', 'G' )
1315	DO ji = 1, nlci-1
1316	iju=iloc-ji
1317	b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1318	END DO
1319	DO ji = nlci/2+1, nlci-1
1320	iju=iloc-ji
1321	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1322	END DO
1323
1324	CASE ( 'I' ) ! ice U-V point
1325	b2( 2 ,nlcj) = 0._wp
1326	DO ji = 2 , nlci-1
1327	ijt = iloc - ji + 2
1328	b2(ji,nlcj)= 0.5 * ( b2(ji,nlcj-1) + psgn * b2(ijt,nlcj-1) )
1329	END DO
1330
1331	END SELECT ! cd_type
1332
1333	END SELECT ! npolj
1334
1335	END SUBROUTINE apply_north_fold_jpni1_2dr
1336
1337	!=========================================================================
1338
1339	SUBROUTINE apply_north_fold_jpni1_3dr(item)
1340	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1341	USE lib_mpp, ONLY: ctl_stop
1342	IMPLICIT None
1343	TYPE (exch_item), INTENT(inout) :: item
1344	!FTRANS b3 :I :I :z
1345	! Locals
1346	INTEGER :: iloc, ji, jk, ijt, iju
1347	REAL(wp) :: psgn
1348	REAL(wp), DIMENSION(:,:,:), POINTER :: b3
1349
1350	!#if defined key_z_first
1351	! CALL ctl_stop('STOP', &
1352	! 'apply_north_fold_jpni1_3dr: key_z_first not implemented for north fold')
1353	! RETURN
1354	!#endif
1355
1356	psgn = REAL(item%isgn, wp)
1357	b3 => item%r3dptr
1358
1359	SELECT CASE ( npolj )
1360
1361	CASE ( 3 , 4 ) ! T pivot
1362	iloc = jpiglo - 2 * ( nimpp - 1 )
1363
1364	SELECT CASE ( item%grid )
1365
1366	CASE ( 'T' , 'S', 'W' )
1367	#if defined key_z_first
1368	DO ji = 2, nlci
1369	DO jk = 1, jpk
1370	ijt=iloc-ji+2
1371	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
1372	END DO
1373	END DO
1374	DO ji = nlci/2+1, nlci
1375	DO jk = 1, jpk
1376	ijt=iloc-ji+2
1377	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1378	END DO
1379	END DO
1380	#else
1381	DO jk = 1, jpk
1382	DO ji = 2, nlci
1383	ijt=iloc-ji+2
1384	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
1385	END DO
1386	DO ji = nlci/2+1, nlci
1387	ijt=iloc-ji+2
1388	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1389	END DO
1390	END DO
1391	#endif
1392
1393	CASE ( 'U' )
1394	#if defined key_z_first
1395	DO ji = 1, nlci-1
1396	DO jk = 1, jpk
1397	iju=iloc-ji+1
1398	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1399	END DO
1400	END DO
1401	DO ji = nlci/2, nlci-1
1402	DO jk = 1, jpk
1403	iju=iloc-ji+1
1404	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1405	END DO
1406	END DO
1407	#else
1408	DO jk = 1, jpk
1409	DO ji = 1, nlci-1
1410	iju=iloc-ji+1
1411	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1412	END DO
1413	DO ji = nlci/2, nlci-1
1414	iju=iloc-ji+1
1415	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1416	END DO
1417	END DO
1418	#endif
1419
1420	CASE ( 'V' )
1421	#if defined key_z_first
1422	DO ji = 2, nlci
1423	DO jk = 1, jpk
1424	#else
1425	DO jk = 1, jpk
1426	DO ji = 2, nlci
1427	#endif
1428	ijt=iloc-ji+2
1429	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-2,jk)
1430	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-3,jk)
1431	END DO
1432	END DO
1433
1434	CASE ( 'F', 'G' )
1435	#if defined key_z_first
1436	DO ji = 1, nlci-1
1437	DO jk = 1, jpk
1438	#else
1439	DO jk = 1, jpk
1440	DO ji = 1, nlci-1
1441	#endif
1442	iju=iloc-ji+1
1443	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-2,jk)
1444	b3(ji,nlcj ,jk) = psgn * b3(iju,nlcj-3,jk)
1445	END DO
1446	END DO
1447
1448	END SELECT
1449
1450	CASE ( 5 , 6 ) ! F pivot
1451	iloc=jpiglo-2*(nimpp-1)
1452
1453	SELECT CASE ( item%grid )
1454
1455	CASE ( 'T' , 'S', 'W' )
1456	#if defined key_z_first
1457	DO ji = 1, nlci
1458	DO jk = 1, jpk
1459	#else
1460	DO jk = 1, jpk
1461	DO ji = 1, nlci
1462	#endif
1463	ijt=iloc-ji+1
1464	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-1,jk)
1465	END DO
1466	END DO
1467
1468	CASE ( 'U' )
1469	#if defined key_z_first
1470	DO ji = 1, nlci-1
1471	DO jk = 1, jpk
1472	#else
1473	DO jk = 1, jpk
1474	DO ji = 1, nlci-1
1475	#endif
1476	iju=iloc-ji
1477	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-1,jk)
1478	END DO
1479	END DO
1480
1481	CASE ( 'V' )
1482	#if defined key_z_first
1483	DO ji = 1, nlci
1484	DO jk = 1, jpk
1485	ijt=iloc-ji+1
1486	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk)
1487	END DO
1488	END DO
1489	DO ji = nlci/2+1, nlci
1490	DO jk = 1, jpk
1491	ijt=iloc-ji+1
1492	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1493	END DO
1494	END DO
1495	#else
1496	DO jk = 1, jpk
1497	DO ji = 1, nlci
1498	ijt=iloc-ji+1
1499	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk)
1500	END DO
1501	DO ji = nlci/2+1, nlci
1502	ijt=iloc-ji+1
1503	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
1504	END DO
1505	END DO
1506	#endif
1507
1508	CASE ( 'F', 'G' )
1509	#if defined key_z_first
1510	DO ji = 1, nlci-1
1511	DO jk = 1, jpk
1512	iju=iloc-ji
1513	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1514	END DO
1515	END DO
1516	DO ji = nlci/2+1, nlci-1
1517	DO jk = 1, jpk
1518	iju=iloc-ji
1519	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1520	END DO
1521	END DO
1522	#else
1523	DO jk = 1, jpk
1524	DO ji = 1, nlci-1
1525	iju=iloc-ji
1526	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
1527	END DO
1528	DO ji = nlci/2+1, nlci-1
1529	iju=iloc-ji
1530	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
1531	END DO
1532	END DO
1533	#endif
1534	END SELECT ! item%grid type
1535
1536	END SELECT ! npolj
1537
1538	END SUBROUTINE apply_north_fold_jpni1_3dr
1539
1540	!=========================================================================
1541
1542	SUBROUTINE apply_north_fold_jpni1_2di(item)
1543	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1544	USE lib_mpp, ONLY: ctl_stop
1545	IMPLICIT None
1546	TYPE (exch_item), INTENT(inout) :: item
1547	! Locals
1548	INTEGER :: iloc, ji, ijt, iju
1549	INTEGER :: isgn
1550	INTEGER, DIMENSION(:,:), POINTER :: ib2
1551
1552	isgn = item%isgn
1553	ib2 => item%i2dptr
1554
1555	SELECT CASE ( npolj )
1556
1557	CASE ( 3 , 4 ) ! T pivot
1558	iloc = jpiglo - 2 * ( nimpp - 1 )
1559
1560	SELECT CASE ( item%grid )
1561
1562	CASE ( 'T' , 'S', 'W' )
1563	DO ji = 2, nlci
1564	ijt=iloc-ji+2
1565	ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-2)
1566	END DO
1567	DO ji = nlci/2+1, nlci
1568	ijt=iloc-ji+2
1569	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
1570	END DO
1571
1572	CASE ( 'U' )
1573	DO ji = 1, nlci-1
1574	iju=iloc-ji+1
1575	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
1576	END DO
1577	DO ji = nlci/2, nlci-1
1578	iju=iloc-ji+1
1579	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
1580	END DO
1581
1582	CASE ( 'V' )
1583	DO ji = 2, nlci
1584	ijt=iloc-ji+2
1585	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-2)
1586	ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-3)
1587	END DO
1588
1589	CASE ( 'F', 'G' )
1590	DO ji = 1, nlci-1
1591	iju=iloc-ji+1
1592	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-2)
1593	ib2(ji,nlcj ) = isgn * ib2(iju,nlcj-3)
1594	END DO
1595
1596	CASE ( 'I' ) ! ice U-V point
1597	ib2(2,nlcj) = isgn * ib2(3,nlcj-1)
1598	DO ji = 3, nlci
1599	iju = iloc - ji + 3
1600	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
1601	END DO
1602
1603	END SELECT
1604
1605	CASE ( 5 , 6 ) ! F pivot
1606	iloc=jpiglo-2*(nimpp-1)
1607
1608	SELECT CASE (item%grid)
1609
1610	CASE ( 'T', 'S', 'W' )
1611	DO ji = 1, nlci
1612	ijt=iloc-ji+1
1613	ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-1)
1614	END DO
1615
1616	CASE ( 'U' )
1617	DO ji = 1, nlci-1
1618	iju=iloc-ji
1619	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
1620	END DO
1621
1622	CASE ( 'V' )
1623	DO ji = 1, nlci
1624	ijt=iloc-ji+1
1625	ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-2)
1626	END DO
1627	DO ji = nlci/2+1, nlci
1628	ijt=iloc-ji+1
1629	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
1630	END DO
1631
1632	CASE ( 'F', 'G' )
1633	DO ji = 1, nlci-1
1634	iju=iloc-ji
1635	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
1636	END DO
1637	DO ji = nlci/2+1, nlci-1
1638	iju=iloc-ji
1639	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
1640	END DO
1641
1642	CASE ( 'I' ) ! ice U-V point
1643	ib2( 2 ,nlcj) = 0._wp
1644	DO ji = 2 , nlci-1
1645	ijt = iloc - ji + 2
1646	ib2(ji,nlcj)= INT(0.5 * ( ib2(ji,nlcj-1) + isgn * ib2(ijt,nlcj-1) ))
1647	END DO
1648
1649	END SELECT ! cd_type
1650
1651	END SELECT ! npolj
1652
1653	END SUBROUTINE apply_north_fold_jpni1_2di
1654
1655	!=========================================================================
1656
1657	SUBROUTINE apply_north_fold_jpni1_3di(item)
1658	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1659	USE lib_mpp, ONLY: ctl_stop
1660	IMPLICIT None
1661	TYPE (exch_item), INTENT(inout) :: item
1662	!FTRANS ib3 :I :I :z
1663	! Locals
1664	INTEGER :: iloc, ji, ijt, iju, jk
1665	INTEGER :: isgn
1666	INTEGER, DIMENSION(:,:,:), POINTER :: ib3
1667
1668	isgn = item%isgn
1669	ib3 => item%i3dptr
1670
1671	SELECT CASE ( npolj )
1672
1673	CASE ( 3 , 4 ) ! T pivot
1674	iloc = jpiglo - 2 * ( nimpp - 1 )
1675
1676	SELECT CASE ( item%grid )
1677
1678	CASE ( 'T' , 'S', 'W' )
1679	#if defined key_z_first
1680	DO ji = 2, nlci
1681	DO jk = 1, jpk
1682	ijt=iloc-ji+2
1683	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
1684	END DO
1685	END DO
1686	DO ji = nlci/2+1, nlci
1687	DO jk = 1, jpk
1688	ijt=iloc-ji+2
1689	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1690	END DO
1691	END DO
1692	#else
1693	DO jk = 1, jpk
1694	DO ji = 2, nlci
1695	ijt=iloc-ji+2
1696	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
1697	END DO
1698	DO ji = nlci/2+1, nlci
1699	ijt=iloc-ji+2
1700	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1701	END DO
1702	END DO
1703	#endif
1704
1705	CASE ( 'U' )
1706	#if defined key_z_first
1707	DO ji = 1, nlci-1
1708	DO jk = 1, jpk
1709	iju=iloc-ji+1
1710	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1711	END DO
1712	END DO
1713	DO ji = nlci/2, nlci-1
1714	DO jk = 1, jpk
1715	iju=iloc-ji+1
1716	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1717	END DO
1718	END DO
1719	#else
1720	DO jk = 1, jpk
1721	DO ji = 1, nlci-1
1722	iju=iloc-ji+1
1723	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1724	END DO
1725	DO ji = nlci/2, nlci-1
1726	iju=iloc-ji+1
1727	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1728	END DO
1729	END DO
1730	#endif
1731
1732	CASE ( 'V' )
1733	#if defined key_z_first
1734	DO ji = 2, nlci
1735	DO jk = 1, jpk
1736	#else
1737	DO jk = 1, jpk
1738	DO ji = 2, nlci
1739	#endif
1740	ijt=iloc-ji+2
1741	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-2,jk)
1742	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-3,jk)
1743	END DO
1744	END DO
1745
1746	CASE ( 'F', 'G' )
1747	#if defined key_z_first
1748	DO ji = 1, nlci-1
1749	DO jk = 1, jpk
1750	#else
1751	DO jk = 1, jpk
1752	DO ji = 1, nlci-1
1753	#endif
1754	iju=iloc-ji+1
1755	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-2,jk)
1756	ib3(ji,nlcj ,jk) = isgn * ib3(iju,nlcj-3,jk)
1757	END DO
1758	END DO
1759
1760	END SELECT
1761
1762	CASE ( 5 , 6 ) ! F pivot
1763	iloc=jpiglo-2*(nimpp-1)
1764
1765	SELECT CASE ( item%grid )
1766
1767	CASE ( 'T' , 'S', 'W' )
1768	#if defined key_z_first
1769	DO ji = 1, nlci
1770	DO jk = 1, jpk
1771	#else
1772	DO jk = 1, jpk
1773	DO ji = 1, nlci
1774	#endif
1775	ijt=iloc-ji+1
1776	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-1,jk)
1777	END DO
1778	END DO
1779
1780	CASE ( 'U' )
1781	#if defined key_z_first
1782	DO ji = 1, nlci-1
1783	DO jk = 1, jpk
1784	#else
1785	DO jk = 1, jpk
1786	DO ji = 1, nlci-1
1787	#endif
1788	iju=iloc-ji
1789	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-1,jk)
1790	END DO
1791	END DO
1792
1793	CASE ( 'V' )
1794	#if defined key_z_first
1795	DO ji = 1, nlci
1796	DO jk = 1, jpk
1797	ijt=iloc-ji+1
1798	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk)
1799	END DO
1800	END DO
1801	DO ji = nlci/2+1, nlci
1802	DO jk = 1, jpk
1803	ijt=iloc-ji+1
1804	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1805	END DO
1806	END DO
1807	#else
1808	DO jk = 1, jpk
1809	DO ji = 1, nlci
1810	ijt=iloc-ji+1
1811	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk)
1812	END DO
1813	DO ji = nlci/2+1, nlci
1814	ijt=iloc-ji+1
1815	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
1816	END DO
1817	END DO
1818	#endif
1819
1820	CASE ( 'F', 'G' )
1821	#if defined key_z_first
1822	DO ji = 1, nlci-1
1823	DO jk = 1, jpk
1824	iju=iloc-ji
1825	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1826	END DO
1827	END DO
1828	DO ji = nlci/2+1, nlci-1
1829	DO jk = 1, jpk
1830	iju=iloc-ji
1831	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1832	END DO
1833	END DO
1834	#else
1835	DO jk = 1, jpk
1836	DO ji = 1, nlci-1
1837	iju=iloc-ji
1838	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
1839	END DO
1840	DO ji = nlci/2+1, nlci-1
1841	iju=iloc-ji
1842	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
1843	END DO
1844	END DO
1845	#endif
1846	END SELECT ! item%grid type
1847
1848	END SELECT ! npolj
1849
1850	END SUBROUTINE apply_north_fold_jpni1_3di
1851
1852	!=========================================================================
1853
1854	SUBROUTINE apply_north_fold2(b2, isgn, cd_type)
1855	USE par_oce, ONLY: wp, jpni, jpk
1856	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1857	USE lib_mpp, ONLY: ctl_stop
1858	IMPLICIT none
1859	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(1:, 1:) :: b2
1860	INTEGER, INTENT(in) :: isgn
1861	CHARACTER (LEN=1), INTENT(in) :: cd_type
1862	! Local variables
1863	INTEGER :: ji, ijt, iju, iloc
1864	REAL(wp) :: psgn
1865
1866	psgn = REAL(isgn, wp)
1867
1868	! Treatment without exchange (jpni odd)
1869
1870	SELECT CASE ( jpni )
1871
1872	CASE ( 1 ) ! only one proc along I, no mpp exchange
1873
1874	SELECT CASE ( npolj )
1875
1876	CASE ( 3 , 4 ) ! T pivot
1877	iloc = jpiglo - 2 * ( nimpp - 1 )
1878
1879	SELECT CASE ( cd_type )
1880
1881	CASE ( 'T' , 'S', 'W' )
1882	DO ji = 2, nlci
1883	ijt=iloc-ji+2
1884	b2(ji,nlcj) = psgn * b2(ijt,nlcj-2)
1885	END DO
1886	DO ji = nlci/2+1, nlci
1887	ijt=iloc-ji+2
1888	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1889	END DO
1890
1891	CASE ( 'U' )
1892	DO ji = 1, nlci-1
1893	iju=iloc-ji+1
1894	b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1895	END DO
1896	DO ji = nlci/2, nlci-1
1897	iju=iloc-ji+1
1898	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1899	END DO
1900
1901	CASE ( 'V' )
1902	DO ji = 2, nlci
1903	ijt=iloc-ji+2
1904	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-2)
1905	b2(ji,nlcj ) = psgn * b2(ijt,nlcj-3)
1906	END DO
1907
1908	CASE ( 'F', 'G' )
1909	DO ji = 1, nlci-1
1910	iju=iloc-ji+1
1911	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-2)
1912	b2(ji,nlcj ) = psgn * b2(iju,nlcj-3)
1913	END DO
1914
1915	CASE ( 'I' ) ! ice U-V point
1916	b2(2,nlcj) = psgn * b2(3,nlcj-1)
1917	DO ji = 3, nlci
1918	iju = iloc - ji + 3
1919	b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1920	END DO
1921
1922	END SELECT
1923
1924	CASE ( 5 , 6 ) ! F pivot
1925	iloc=jpiglo-2*(nimpp-1)
1926
1927	SELECT CASE (cd_type )
1928
1929	CASE ( 'T', 'S', 'W' )
1930	DO ji = 1, nlci
1931	ijt=iloc-ji+1
1932	b2(ji,nlcj) = psgn * b2(ijt,nlcj-1)
1933	END DO
1934
1935	CASE ( 'U' )
1936	DO ji = 1, nlci-1
1937	iju=iloc-ji
1938	b2(ji,nlcj) = psgn * b2(iju,nlcj-1)
1939	END DO
1940
1941	CASE ( 'V' )
1942	DO ji = 1, nlci
1943	ijt=iloc-ji+1
1944	b2(ji,nlcj ) = psgn * b2(ijt,nlcj-2)
1945	END DO
1946	DO ji = nlci/2+1, nlci
1947	ijt=iloc-ji+1
1948	b2(ji,nlcj-1) = psgn * b2(ijt,nlcj-1)
1949	END DO
1950
1951	CASE ( 'F', 'G' )
1952	DO ji = 1, nlci-1
1953	iju=iloc-ji
1954	b2(ji,nlcj) = psgn * b2(iju,nlcj-2)
1955	END DO
1956	DO ji = nlci/2+1, nlci-1
1957	iju=iloc-ji
1958	b2(ji,nlcj-1) = psgn * b2(iju,nlcj-1)
1959	END DO
1960
1961	CASE ( 'I' ) ! ice U-V point
1962	b2( 2 ,nlcj) = 0._wp
1963	DO ji = 2 , nlci-1
1964	ijt = iloc - ji + 2
1965	b2(ji,nlcj)= 0.5 * ( b2(ji,nlcj-1) + psgn * b2(ijt,nlcj-1) )
1966	END DO
1967
1968	END SELECT ! cd_type
1969
1970	END SELECT ! npolj
1971
1972	CASE DEFAULT ! more than 1 proc along I
1973	IF( npolj /= 0 .AND. do_nfold ) CALL mpp_lbc_north( b2, cd_type, psgn ) ! only for northern procs.
1974
1975	END SELECT ! jpni
1976
1977	END SUBROUTINE apply_north_fold2
1978
1979	!=========================================================================
1980
1981	SUBROUTINE apply_north_fold2i(ib2, isgn, cd_type)
1982	USE par_oce, ONLY: wp, jpni, jpk
1983	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
1984	USE lib_mpp, ONLY: ctl_stop
1985	IMPLICIT none
1986	INTEGER, INTENT(inout), DIMENSION(1:, 1:) :: ib2
1987	INTEGER, INTENT(in) :: isgn
1988	CHARACTER (LEN=1), INTENT(in) :: cd_type
1989	! Local variables
1990	INTEGER :: ji, ijt, iju, iloc
1991
1992
1993	#if defined key_z_first
1994	CALL ctl_stop('STOP', &
1995	'apply_north_fold2i: key_z_first not implemented for north fold')
1996	RETURN
1997	#endif
1998
1999	! Treatment without exchange (jpni odd)
2000
2001	SELECT CASE ( jpni )
2002
2003	CASE ( 1 ) ! only one proc along I, no mpp exchange
2004
2005	SELECT CASE ( npolj )
2006
2007	CASE ( 3 , 4 ) ! T pivot
2008	iloc = jpiglo - 2 * ( nimpp - 1 )
2009
2010	SELECT CASE ( cd_type )
2011
2012	CASE ( 'T' , 'S', 'W' )
2013	DO ji = 2, nlci
2014	ijt=iloc-ji+2
2015	ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-2)
2016	END DO
2017	DO ji = nlci/2+1, nlci
2018	ijt=iloc-ji+2
2019	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
2020	END DO
2021
2022	CASE ( 'U' )
2023	DO ji = 1, nlci-1
2024	iju=iloc-ji+1
2025	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
2026	END DO
2027	DO ji = nlci/2, nlci-1
2028	iju=iloc-ji+1
2029	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
2030	END DO
2031
2032	CASE ( 'V' )
2033	DO ji = 2, nlci
2034	ijt=iloc-ji+2
2035	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-2)
2036	ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-3)
2037	END DO
2038
2039	CASE ( 'F', 'G' )
2040	DO ji = 1, nlci-1
2041	iju=iloc-ji+1
2042	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-2)
2043	ib2(ji,nlcj ) = isgn * ib2(iju,nlcj-3)
2044	END DO
2045
2046	CASE ( 'I' ) ! ice U-V point
2047	ib2(2,nlcj) = isgn * ib2(3,nlcj-1)
2048	DO ji = 3, nlci
2049	iju = iloc - ji + 3
2050	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
2051	END DO
2052
2053	END SELECT
2054
2055	CASE ( 5 , 6 ) ! F pivot
2056	iloc=jpiglo-2*(nimpp-1)
2057
2058	SELECT CASE (cd_type )
2059
2060	CASE ( 'T', 'S', 'W' )
2061	DO ji = 1, nlci
2062	ijt=iloc-ji+1
2063	ib2(ji,nlcj) = isgn * ib2(ijt,nlcj-1)
2064	END DO
2065
2066	CASE ( 'U' )
2067	DO ji = 1, nlci-1
2068	iju=iloc-ji
2069	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-1)
2070	END DO
2071
2072	CASE ( 'V' )
2073	DO ji = 1, nlci
2074	ijt=iloc-ji+1
2075	ib2(ji,nlcj ) = isgn * ib2(ijt,nlcj-2)
2076	END DO
2077	DO ji = nlci/2+1, nlci
2078	ijt=iloc-ji+1
2079	ib2(ji,nlcj-1) = isgn * ib2(ijt,nlcj-1)
2080	END DO
2081
2082	CASE ( 'F', 'G' )
2083	DO ji = 1, nlci-1
2084	iju=iloc-ji
2085	ib2(ji,nlcj) = isgn * ib2(iju,nlcj-2)
2086	END DO
2087	DO ji = nlci/2+1, nlci-1
2088	iju=iloc-ji
2089	ib2(ji,nlcj-1) = isgn * ib2(iju,nlcj-1)
2090	END DO
2091
2092	CASE ( 'I' ) ! ice U-V point
2093	ib2( 2 ,nlcj) = 0._wp
2094	DO ji = 2 , nlci-1
2095	ijt = iloc - ji + 2
2096	ib2(ji,nlcj)= INT(0.5 * ( ib2(ji,nlcj-1) + isgn * ib2(ijt,nlcj-1) ))
2097	END DO
2098
2099	END SELECT ! cd_type
2100
2101	END SELECT ! npolj
2102
2103	CASE DEFAULT ! more than 1 proc along I
2104	IF( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north( ib2, cd_type, isgn ) ! only for northern procs.
2105
2106	END SELECT ! jpni
2107
2108	END SUBROUTINE apply_north_fold2i
2109
2110	!=========================================================================
2111
2112	SUBROUTINE apply_north_fold3(b3, isgn, cd_type)
2113	USE par_oce, ONLY: wp, jpni, jpk
2114	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
2115	USE lib_mpp, ONLY: ctl_stop
2116	IMPLICIT none
2117	!FTRANS b3 :I :I :z
2118	REAL(wp), INTENT(inout), DIMENSION(1:, 1:, 1:) :: b3
2119	INTEGER, INTENT(in) :: isgn
2120	CHARACTER (LEN=1), INTENT(in) :: cd_type
2121	! Local variables
2122	INTEGER :: ji, jk, ijt, iju, iloc
2123	REAL(wp) :: psgn
2124	!!----------------------------------------------------------------------
2125
2126	psgn = REAL(isgn, wp)
2127
2128	! Treatment without exchange (jpni odd)
2129	! T-point pivot
2130
2131	SELECT CASE ( jpni )
2132
2133	CASE ( 1 ) ! only one proc along I, no mpp exchange
2134
2135	SELECT CASE ( npolj )
2136
2137	CASE ( 3 , 4 ) ! T pivot
2138	iloc = jpiglo - 2 * ( nimpp - 1 )
2139
2140	SELECT CASE ( cd_type )
2141
2142	CASE ( 'T' , 'S', 'W' )
2143	#if defined key_z_first
2144	DO ji = 2, nlci
2145	DO jk = 1, jpk
2146	ijt=iloc-ji+2
2147	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
2148	END DO
2149	END DO
2150	DO ji = nlci/2+1, nlci
2151	DO jk = 1, jpk
2152	ijt=iloc-ji+2
2153	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2154	END DO
2155	END DO
2156	#else
2157	DO jk = 1, jpk
2158	DO ji = 2, nlci
2159	ijt=iloc-ji+2
2160	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-2,jk)
2161	END DO
2162	DO ji = nlci/2+1, nlci
2163	ijt=iloc-ji+2
2164	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2165	END DO
2166	END DO
2167	#endif
2168
2169	CASE ( 'U' )
2170	#if defined key_z_first
2171	DO ji = 1, nlci-1
2172	DO jk = 1, jpk
2173	iju=iloc-ji+1
2174	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2175	END DO
2176	END DO
2177	DO ji = nlci/2, nlci-1
2178	DO jk = 1, jpk
2179	iju=iloc-ji+1
2180	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2181	END DO
2182	END DO
2183	#else
2184	DO jk = 1, jpk
2185	DO ji = 1, nlci-1
2186	iju=iloc-ji+1
2187	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2188	END DO
2189	DO ji = nlci/2, nlci-1
2190	iju=iloc-ji+1
2191	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2192	END DO
2193	END DO
2194	#endif
2195
2196	CASE ( 'V' )
2197	#if defined key_z_first
2198	DO ji = 2, nlci
2199	DO jk = 1, jpk
2200	#else
2201	DO jk = 1, jpk
2202	DO ji = 2, nlci
2203	#endif
2204	ijt=iloc-ji+2
2205	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-2,jk)
2206	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-3,jk)
2207	END DO
2208	END DO
2209
2210	CASE ( 'F', 'G' )
2211	#if defined key_z_first
2212	DO ji = 1, nlci-1
2213	DO jk = 1, jpk
2214	#else
2215	DO jk = 1, jpk
2216	DO ji = 1, nlci-1
2217	#endif
2218	iju=iloc-ji+1
2219	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-2,jk)
2220	b3(ji,nlcj ,jk) = psgn * b3(iju,nlcj-3,jk)
2221	END DO
2222	END DO
2223
2224	END SELECT
2225
2226	CASE ( 5 , 6 ) ! F pivot
2227	iloc=jpiglo-2*(nimpp-1)
2228
2229	SELECT CASE ( cd_type )
2230
2231	CASE ( 'T' , 'S', 'W' )
2232	#if defined key_z_first
2233	DO ji = 1, nlci
2234	DO jk = 1, jpk
2235	#else
2236	DO jk = 1, jpk
2237	DO ji = 1, nlci
2238	#endif
2239	ijt=iloc-ji+1
2240	b3(ji,nlcj,jk) = psgn * b3(ijt,nlcj-1,jk)
2241	END DO
2242	END DO
2243
2244	CASE ( 'U' )
2245	#if defined key_z_first
2246	DO ji = 1, nlci-1
2247	DO jk = 1, jpk
2248	#else
2249	DO jk = 1, jpk
2250	DO ji = 1, nlci-1
2251	#endif
2252	iju=iloc-ji
2253	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-1,jk)
2254	END DO
2255	END DO
2256
2257	CASE ( 'V' )
2258	#if defined key_z_first
2259	DO ji = 1, nlci
2260	DO jk = 1, jpk
2261	ijt=iloc-ji+1
2262	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk)
2263	END DO
2264	END DO
2265	DO ji = nlci/2+1, nlci
2266	DO jk = 1, jpk
2267	ijt=iloc-ji+1
2268	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2269	END DO
2270	END DO
2271	#else
2272	DO jk = 1, jpk
2273	DO ji = 1, nlci
2274	ijt=iloc-ji+1
2275	b3(ji,nlcj ,jk) = psgn * b3(ijt,nlcj-2,jk)
2276	END DO
2277	DO ji = nlci/2+1, nlci
2278	ijt=iloc-ji+1
2279	b3(ji,nlcj-1,jk) = psgn * b3(ijt,nlcj-1,jk)
2280	END DO
2281	END DO
2282	#endif
2283
2284	CASE ( 'F', 'G' )
2285	#if defined key_z_first
2286	DO ji = 1, nlci-1
2287	DO jk = 1, jpk
2288	iju=iloc-ji
2289	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2290	END DO
2291	END DO
2292	DO ji = nlci/2+1, nlci-1
2293	DO jk = 1, jpk
2294	iju=iloc-ji
2295	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2296	END DO
2297	END DO
2298	#else
2299	DO jk = 1, jpk
2300	DO ji = 1, nlci-1
2301	iju=iloc-ji
2302	b3(ji,nlcj,jk) = psgn * b3(iju,nlcj-2,jk)
2303	END DO
2304	DO ji = nlci/2+1, nlci-1
2305	iju=iloc-ji
2306	b3(ji,nlcj-1,jk) = psgn * b3(iju,nlcj-1,jk)
2307	END DO
2308	END DO
2309	#endif
2310	END SELECT ! cd_type
2311
2312	END SELECT ! npolj
2313
2314	CASE DEFAULT ! more than 1 proc along I
2315	IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north (b3, cd_type, psgn) ! only for northern procs.
2316
2317	END SELECT ! jpni
2318
2319	END SUBROUTINE apply_north_fold3
2320
2321	!=========================================================================
2322
2323	SUBROUTINE apply_north_fold3i(ib3, isgn, cd_type)
2324	USE par_oce, ONLY: wp, jpni, jpk
2325	USE dom_oce, ONLY: npolj, nlci, nlcj, nimpp
2326	USE lib_mpp, ONLY: ctl_stop
2327	IMPLICIT none
2328	!FTRANS ib3 :I :I :z
2329	INTEGER, INTENT(inout), DIMENSION(1:, 1:, :) :: ib3
2330	INTEGER, INTENT(in) :: isgn
2331	CHARACTER (LEN=1), INTENT(in) :: cd_type
2332	! Local variables
2333	INTEGER :: ji, jk, ijt, iju, iloc
2334
2335	! 4.1 treatment without exchange (jpni odd)
2336	! T-point pivot
2337
2338	SELECT CASE ( jpni )
2339
2340	CASE ( 1 ) ! only one proc along I, no mpp exchange
2341
2342	SELECT CASE ( npolj )
2343
2344	CASE ( 3 , 4 ) ! T pivot
2345	iloc = jpiglo - 2 * ( nimpp - 1 )
2346
2347	SELECT CASE ( cd_type )
2348
2349	CASE ( 'T' , 'S', 'W' )
2350	#if defined key_z_first
2351	DO ji = 2, nlci
2352	DO jk = 1, jpk
2353	ijt=iloc-ji+2
2354	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
2355	END DO
2356	END DO
2357	DO ji = nlci/2+1, nlci
2358	DO jk = 1, jpk
2359	ijt=iloc-ji+2
2360	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2361	END DO
2362	END DO
2363	#else
2364	DO jk = 1, jpk
2365	DO ji = 2, nlci
2366	ijt=iloc-ji+2
2367	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-2,jk)
2368	END DO
2369	DO ji = nlci/2+1, nlci
2370	ijt=iloc-ji+2
2371	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2372	END DO
2373	END DO
2374	#endif
2375
2376	CASE ( 'U' )
2377	#if defined key_z_first
2378	DO ji = 1, nlci-1
2379	DO jk = 1, jpk
2380	iju=iloc-ji+1
2381	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2382	END DO
2383	END DO
2384	DO ji = nlci/2, nlci-1
2385	DO jk = 1, jpk
2386	iju=iloc-ji+1
2387	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2388	END DO
2389	END DO
2390	#else
2391	DO jk = 1, jpk
2392	DO ji = 1, nlci-1
2393	iju=iloc-ji+1
2394	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2395	END DO
2396	DO ji = nlci/2, nlci-1
2397	iju=iloc-ji+1
2398	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2399	END DO
2400	END DO
2401	#endif
2402
2403	CASE ( 'V' )
2404	#if defined key_z_first
2405	DO ji = 2, nlci
2406	DO jk = 1, jpk
2407	#else
2408	DO jk = 1, jpk
2409	DO ji = 2, nlci
2410	#endif
2411	ijt=iloc-ji+2
2412	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-2,jk)
2413	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-3,jk)
2414	END DO
2415	END DO
2416
2417	CASE ( 'F', 'G' )
2418	#if defined key_z_first
2419	DO ji = 1, nlci-1
2420	DO jk = 1, jpk
2421	#else
2422	DO jk = 1, jpk
2423	DO ji = 1, nlci-1
2424	#endif
2425	iju=iloc-ji+1
2426	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-2,jk)
2427	ib3(ji,nlcj ,jk) = isgn * ib3(iju,nlcj-3,jk)
2428	END DO
2429	END DO
2430
2431	END SELECT
2432
2433	CASE ( 5 , 6 ) ! F pivot
2434	iloc=jpiglo-2*(nimpp-1)
2435
2436	SELECT CASE ( cd_type )
2437
2438	CASE ( 'T' , 'S', 'W' )
2439	#if defined key_z_first
2440	DO ji = 1, nlci
2441	DO jk = 1, jpk
2442	#else
2443	DO jk = 1, jpk
2444	DO ji = 1, nlci
2445	#endif
2446	ijt=iloc-ji+1
2447	ib3(ji,nlcj,jk) = isgn * ib3(ijt,nlcj-1,jk)
2448	END DO
2449	END DO
2450
2451	CASE ( 'U' )
2452	#if defined key_z_first
2453	DO ji = 1, nlci-1
2454	DO jk = 1, jpk
2455	#else
2456	DO jk = 1, jpk
2457	DO ji = 1, nlci-1
2458	#endif
2459	iju=iloc-ji
2460	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-1,jk)
2461	END DO
2462	END DO
2463
2464	CASE ( 'V' )
2465	#if defined key_z_first
2466	DO ji = 1, nlci
2467	DO jk = 1, jpk
2468	ijt=iloc-ji+1
2469	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk)
2470	END DO
2471	END DO
2472	DO ji = nlci/2+1, nlci
2473	DO jk = 1, jpk
2474	ijt=iloc-ji+1
2475	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2476	END DO
2477	END DO
2478	#else
2479	DO jk = 1, jpk
2480	DO ji = 1, nlci
2481	ijt=iloc-ji+1
2482	ib3(ji,nlcj ,jk) = isgn * ib3(ijt,nlcj-2,jk)
2483	END DO
2484	DO ji = nlci/2+1, nlci
2485	ijt=iloc-ji+1
2486	ib3(ji,nlcj-1,jk) = isgn * ib3(ijt,nlcj-1,jk)
2487	END DO
2488	END DO
2489	#endif
2490
2491	CASE ( 'F', 'G' )
2492	#if defined key_z_first
2493	DO ji = 1, nlci-1
2494	DO jk = 1, jpk
2495	iju=iloc-ji
2496	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2497	END DO
2498	END DO
2499	DO ji = nlci/2+1, nlci-1
2500	DO jk = 1, jpk
2501	iju=iloc-ji
2502	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2503	END DO
2504	END DO
2505	#else
2506	DO jk = 1, jpk
2507	DO ji = 1, nlci-1
2508	iju=iloc-ji
2509	ib3(ji,nlcj,jk) = isgn * ib3(iju,nlcj-2,jk)
2510	END DO
2511	DO ji = nlci/2+1, nlci-1
2512	iju=iloc-ji
2513	ib3(ji,nlcj-1,jk) = isgn * ib3(iju,nlcj-1,jk)
2514	END DO
2515	END DO
2516	#endif
2517
2518	END SELECT ! cd_type
2519
2520	END SELECT ! npolj
2521
2522	CASE DEFAULT ! more than 1 proc along I
2523	IF ( npolj /= 0 .AND. do_nfold) CALL mpp_lbc_north ( ib3, cd_type, isgn) ! only for northern procs.
2524
2525	END SELECT ! jpni
2526
2527	END SUBROUTINE apply_north_fold3i
2528
2529	!================================================================
2530
2531	SUBROUTINE add_exch(iwidth, grid, dirn1, &
2532	dirn2, dirn3, dirn4, &
2533	r2d, r3d, i2d, i3d, isgn, lfill)
2534	USE lib_mpp, ONLY: ctl_stop
2535	IMPLICIT none
2536	! Arguments
2537	INTEGER :: iwidth, dirn1, dirn2, dirn3, dirn4
2538	CHARACTER (LEN=1) :: grid
2539	REAL(wp), DIMENSION(:,:), TARGET, OPTIONAL :: r2d
2540	REAL(wp), DIMENSION(:,:,:), TARGET, OPTIONAL :: r3d
2541	INTEGER, DIMENSION(:,:), TARGET, OPTIONAL :: i2d
2542	INTEGER, DIMENSION(:,:,:), TARGET, OPTIONAL :: i3d
2543	INTEGER, OPTIONAL :: isgn
2544	LOGICAL, OPTIONAL :: lfill
2545	! Local vars
2546	!!--------------------------------------------------------------------
2547
2548	#if ! defined key_mpp_rkpart
2549	RETURN
2550	#endif
2551
2552	IF(nextFreeExchItem > maxExchItems)THEN
2553	CALL ctl_stop('STOP','ARPDBG: implement reallocate in add_exch')
2554	RETURN
2555	END IF
2556
2557	exch_list(nextFreeExchItem)%halo_width = iwidth
2558
2559	exch_list(nextFreeExchItem)%dirn(1) = dirn1
2560	exch_list(nextFreeExchItem)%dirn(2) = dirn2
2561	exch_list(nextFreeExchItem)%dirn(3) = dirn3
2562	exch_list(nextFreeExchItem)%dirn(4) = dirn4
2563
2564	exch_list(nextFreeExchItem)%grid = grid
2565
2566	IF(PRESENT(isgn))THEN
2567	exch_list(nextFreeExchItem)%isgn = isgn
2568	ELSE
2569	exch_list(nextFreeExchItem)%isgn = 1
2570	END IF
2571
2572	NULLIFY( exch_list(nextFreeExchItem)%r2dptr, &
2573	exch_list(nextFreeExchItem)%r3dptr, &
2574	exch_list(nextFreeExchItem)%i2dptr, &
2575	exch_list(nextFreeExchItem)%i3dptr )
2576
2577	IF(PRESENT(r2d))THEN
2578	exch_list(nextFreeExchItem)%r2dptr => r2d
2579	ELSE IF(PRESENT(r3d))THEN
2580	exch_list(nextFreeExchItem)%r3dptr => r3d
2581	ELSE IF(PRESENT(i2d))THEN
2582	exch_list(nextFreeExchItem)%i2dptr => i2d
2583	ELSE IF(PRESENT(i3d))THEN
2584	exch_list(nextFreeExchItem)%i3dptr => i3d
2585	ELSE
2586	! This section is both for error checking and allows me to be lazy in the
2587	! testing code - I don't have to check which arrays I've been passed
2588	! before I call this routine.
2589	WRITE (,) 'WARNING: add_exch called without a ptr to an array - will be ignored'
2590	RETURN
2591	END IF
2592
2593	IF(PRESENT(lfill))THEN
2594	exch_list(nextFreeExchItem)%lfill = lfill
2595	ELSE
2596	exch_list(nextFreeExchItem)%lfill = .false.
2597	END IF
2598
2599	nextFreeExchItem = nextFreeExchItem + 1
2600
2601	END SUBROUTINE add_exch
2602
2603	!================================================================
2604
2605	SUBROUTINE wipe_exch(item)
2606	IMPLICIT none
2607	! Arguments
2608	TYPE (exch_item), INTENT(inout) :: item
2609
2610	NULLIFY(item%i2dptr, item%r2dptr, item%i3dptr, item%r3dptr)
2611	item%isgn = 1
2612
2613	END SUBROUTINE wipe_exch
2614
2615	!================================================================
2616
2617	SUBROUTINE bound_exch2 (b, nhalo, nhexch, &
2618	comm1, comm2, comm3, comm4, &
2619	cd_type, lfill, pval, isgn, lzero )
2620	!!----------------------------------------------------------------------
2621	!!----------------------------------------------------------------------
2622	USE par_oce, ONLY : wp
2623	IMPLICIT none
2624	REAL(wp), INTENT(inout), DIMENSION(:,:) :: b
2625	INTEGER, INTENT(in) :: nhalo,nhexch
2626	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
2627	CHARACTER (LEN=1), INTENT(in) :: cd_type
2628	LOGICAL, OPTIONAL, INTENT(in) :: lfill
2629	INTEGER, OPTIONAL, INTENT(in) :: isgn
2630	LOGICAL, OPTIONAL, INTENT(in) :: lzero
2631	REAL(wp),OPTIONAL, INTENT(in) :: pval
2632
2633	CALL bound_exch_generic( b2=b,nhalo=nhalo,nhexch=nhexch, &
2634	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2635	cd_type=cd_type, lfill=lfill, pval=pval, &
2636	isgn=isgn, lzero=lzero )
2637	RETURN
2638	END SUBROUTINE bound_exch2
2639
2640
2641	SUBROUTINE bound_exch2i (b, nhalo, nhexch, comm1, comm2, comm3, comm4, &
2642	cd_type, lfill, pval, isgn, lzero )
2643	!!----------------------------------------------------------------------
2644	!!----------------------------------------------------------------------
2645	USE par_oce, ONLY: wp
2646	IMPLICIT none
2647	INTEGER, INTENT(inout), DIMENSION(:,:) :: b
2648	INTEGER, INTENT(in) :: nhalo,nhexch
2649	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
2650	CHARACTER (LEN=1), INTENT(in) :: cd_type
2651	LOGICAL, OPTIONAL, INTENT(in) :: lfill
2652	INTEGER, OPTIONAL, INTENT(in) :: isgn
2653	LOGICAL, OPTIONAL, INTENT(in) :: lzero
2654	REAL(wp),OPTIONAL, INTENT(in) :: pval
2655
2656	CALL bound_exch_generic (ib2=b,nhalo=nhalo,nhexch=nhexch, &
2657	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2658	cd_type=cd_type, lfill=lfill, pval=pval, &
2659	isgn=isgn, lzero=lzero )
2660	RETURN
2661	END SUBROUTINE bound_exch2i
2662
2663
2664	SUBROUTINE bound_exch3 (b, nhalo, nhexch, comm1, comm2, comm3, &
2665	comm4, cd_type, lfill, pval, isgn, lzero)
2666	!!----------------------------------------------------------------------
2667	!!----------------------------------------------------------------------
2668	USE par_oce, ONLY: wp
2669	IMPLICIT none
2670	REAL(wp), INTENT(inout), DIMENSION(:,:,:) :: b
2671	INTEGER, INTENT(in) :: nhalo,nhexch
2672	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
2673	CHARACTER (LEN=1), INTENT(in) :: cd_type
2674	LOGICAL, OPTIONAL, INTENT(in) :: lfill
2675	INTEGER, OPTIONAL, INTENT(in) :: isgn
2676	LOGICAL, OPTIONAL, INTENT(in) :: lzero
2677	REAL(wp),OPTIONAL, INTENT(in) :: pval
2678
2679	CALL bound_exch_generic ( b3=b,nhalo=nhalo,nhexch=nhexch,&
2680	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2681	cd_type=cd_type, lfill=lfill, pval=pval, &
2682	isgn=isgn, lzero=lzero )
2683	RETURN
2684	END SUBROUTINE bound_exch3
2685
2686
2687	SUBROUTINE bound_exch3i (b, nhalo, nhexch, comm1, comm2, comm3, &
2688	comm4, cd_type, lfill, pval, isgn, lzero)
2689	!!----------------------------------------------------------------------
2690	!!----------------------------------------------------------------------
2691	IMPLICIT none
2692	INTEGER, INTENT(inout), DIMENSION(:,:,:) :: b
2693	INTEGER, INTENT(in) :: nhalo,nhexch
2694	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
2695	CHARACTER (LEN=1), INTENT(in) :: cd_type
2696	LOGICAL, OPTIONAL, INTENT(in) :: lfill
2697	INTEGER, OPTIONAL, INTENT(in) :: isgn
2698	LOGICAL, OPTIONAL, INTENT(in) :: lzero
2699	REAL(wp),OPTIONAL, INTENT(in) :: pval
2700
2701	CALL bound_exch_generic ( ib3=b,nhalo=nhalo,nhexch=nhexch, &
2702	comm1=comm1,comm2=comm2,comm3=comm3,comm4=comm4, &
2703	cd_type=cd_type, lfill=lfill, pval=pval, &
2704	isgn=isgn, lzero=lzero )
2705
2706	END SUBROUTINE bound_exch3i
2707
2708
2709	SUBROUTINE lbc_exch2( pt2d, cd_type, psgn, cd_mpp, pval, lzero )
2710	USE par_oce, ONLY: wp, jpreci
2711	USE lib_mpp, ONLY : ctl_stop
2712	IMPLICIT none
2713	!!----------------------------------------------------------------------
2714	!! * routine mpp_lnk_2d *
2715	!!
2716	!! ** Purpose : Message passing management for 2d array
2717	!!
2718	!! ** Method : Use bound_exch_generic to update halos on neighbouring
2719	!! processes.
2720	!!
2721	!!----------------------------------------------------------------------
2722	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
2723	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
2724	! ! = T , U , V , F , W and I points
2725	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
2726	! ! = 1. , the sign is kept
2727	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
2728	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
2729	LOGICAL, OPTIONAL , INTENT(in ) :: lzero ! Whether to zero halos on closed boundaries
2730
2731	! Locals
2732	LOGICAL :: lfill
2733
2734	lfill = .FALSE.
2735	IF(PRESENT(cd_mpp))THEN
2736	lfill = .TRUE.
2737	END IF
2738
2739	CALL bound_exch_generic( b2=pt2d,nhalo=jpreci,nhexch=jpreci, &
2740	comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
2741	cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), &
2742	lzero=lzero )
2743
2744	END SUBROUTINE lbc_exch2
2745
2746
2747	SUBROUTINE lbc_exch3( ptab3d, cd_type, psgn, cd_mpp, pval, lzero )
2748	USE par_oce, ONLY: wp, jpreci
2749	USE lib_mpp, ONLY : ctl_stop
2750	IMPLICIT none
2751	!!----------------------------------------------------------------------
2752	!!----------------------------------------------------------------------
2753	!FTRANS ptab3d :I :I :z
2754	REAL(wp), INTENT(inout) :: ptab3d(jpi,jpj,jpk)
2755	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
2756	! ! = T , U , V , F , W points
2757	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
2758	! ! = 1. , the sign is kept
2759	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
2760	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
2761	LOGICAL, OPTIONAL , INTENT(in ) :: lzero ! Whether to zero halos on closed boundaries
2762	! Locals
2763	LOGICAL :: lfill
2764
2765	lfill = .FALSE.
2766	IF(PRESENT(cd_mpp))THEN
2767	lfill = .TRUE.
2768	END IF
2769
2770	CALL bound_exch_generic ( b3=ptab3d,nhalo=jpreci,nhexch=jpreci, &
2771	comm1=Iplus,comm2=Iminus,comm3=Jplus,comm4=Jminus, &
2772	cd_type=cd_type, lfill=lfill, pval=pval, isgn=INT(psgn), &
2773	lzero=lzero )
2774
2775	END SUBROUTINE lbc_exch3
2776
2777	! ****************************************************************************
2778
2779	SUBROUTINE exchs_generic_list (list, nfields)
2780
2781	! **************************************************************************
2782	! Send boundary data elements to adjacent sub-domains.
2783	!
2784	! handle int output Exchange handle.
2785	! comm1 int input Send in direction comm1.
2786	! comm2 int input Send in direction comm2.
2787	! comm3 int input Send in direction comm3.
2788	! comm4 int input Send in direction comm4.
2789	! cd_type char input Nature of array grid-points
2790	! = T , U , V , F , W points
2791	! = S : T-point, north fold treatment?
2792	! = G : F-point, north fold treatment?
2793	! lfill logical input Whether to simply fill
2794	! overlap region or apply b.c.'s
2795	!
2796	! Mike Ashworth, CCLRC, March 2005.
2797	! Andrew Porter, STFC, January 2008
2798	! **************************************************************************
2799	USE par_oce, ONLY: wp, jpreci, jprecj, jpni
2800	USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, &
2801	IminusJminus, IplusJminus, IminusJplus, &
2802	nsend, nxsend, nysend, nxsendp,nysendp,nzsendp, &
2803	nsendp, &
2804	destination,dirsend, dirrecv, &
2805	isrcsendp,jsrcsendp, idesrecvp, jdesrecvp, &
2806	nrecv, &
2807	nxrecvp,nyrecvp,nzrecvp, nrecvp, nrecvp2d, &
2808	source, iesub, jesub, &
2809	MaxCommDir, MaxComm, cyclic_bc, &
2810	nrecvp, npatchsend, npatchrecv
2811	USE lib_mpp, ONLY: ctl_stop
2812	#if defined key_mpp_mpi
2813	USE lib_mpp, ONLY: mpi_comm_opa
2814	#endif
2815	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
2816	USE dom_oce, ONLY: narea
2817	#endif
2818	IMPLICIT none
2819
2820	! Subroutine arguments.
2821	TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
2822	INTEGER, INTENT(in) :: nfields
2823
2824	! Local variables.
2825
2826	LOGICAL :: enabled(0:MaxCommDir, maxExchItems)
2827	INTEGER :: ides, ierr, irecv, isend, &
2828	isrc, jdes, jsrc, tag, tag_orig, &
2829	ibeg, iend, jbeg, jend
2830	INTEGER :: i, j, k, ic, ifield, ipatch ! Loop counters
2831	! No. of array elements packed
2832	INTEGER :: npacked
2833	INTEGER :: handle
2834	#if defined key_mpp_mpi
2835	INTEGER :: status(MPI_status_size)
2836	INTEGER :: astatus(MPI_status_size,MaxComm)
2837	#endif
2838	INTEGER :: r2dcount, r3dcount, i2dcount, i3dcount
2839	! Indices into int and real copy buffers
2840	INTEGER :: istart, rstart
2841	! Max no. of points to send/recv (for alloc'ing buffers)
2842	INTEGER :: maxrecvpts, maxsendpts
2843	LOGICAL, SAVE :: first_time = .TRUE.
2844	LOGICAL :: have_real_field, have_int_field
2845	! Required size of buffer for current send
2846	INTEGER :: newSize
2847	! The current size (in array elements) of the send buffer
2848	INTEGER, SAVE :: sendIBuffSize = 0
2849	INTEGER, SAVE :: sendBuffSize = 0
2850	#if defined key_z_first
2851	INTEGER, PARAMETER :: index_z = 1
2852	#else
2853	INTEGER, PARAMETER :: index_z = 3
2854	#endif
2855	!!--------------------------------------------------------------------
2856
2857	#if ! defined key_mpp_rkpart
2858	RETURN
2859	#endif
2860
2861	!CALL prof_region_begin(ARPEXCHS_LIST, "Exchs_list", iprofStat)
2862
2863	! Allocate a communications tag/handle and a flags array.
2864
2865	handle = get_exch_handle()
2866	tag_orig = exch_tag(handle)
2867
2868	have_real_field = .FALSE.
2869	have_int_field = .FALSE.
2870
2871	! Set enabled flags according to the field details.
2872	DO ifield = 1, nfields, 1
2873
2874	! Check halo width is in range.
2875	IF ( list(ifield)%halo_width.GT.jpreci ) THEN
2876	CALL ctl_stop('STOP', &
2877	'exchs_generic_list: halo width greater than maximum')
2878	RETURN
2879	ENDIF
2880
2881	enabled(Iplus, ifield ) = .FALSE.
2882	enabled(Jplus, ifield ) = .FALSE.
2883	enabled(Iminus, ifield) = .FALSE.
2884	enabled(Jminus, ifield) = .FALSE.
2885	enabled(list(ifield)%dirn(1), ifield) = list(ifield)%dirn(1).GT.0
2886	enabled(list(ifield)%dirn(2), ifield) = list(ifield)%dirn(2).GT.0
2887	enabled(list(ifield)%dirn(3), ifield) = list(ifield)%dirn(3).GT.0
2888	enabled(list(ifield)%dirn(4), ifield) = list(ifield)%dirn(4).GT.0
2889
2890	! Set diagonal communications according to the non-diagonal flags.
2891
2892	enabled(IplusJplus, ifield ) = enabled(Iplus, ifield ).AND.enabled(Jplus, ifield )
2893	enabled(IminusJminus,ifield ) = enabled(Iminus, ifield ).AND.enabled(Jminus, ifield )
2894	enabled(IplusJminus, ifield ) = enabled(Iplus, ifield ).AND.enabled(Jminus, ifield )
2895	enabled(IminusJplus, ifield ) = enabled(Iminus, ifield ).AND.enabled(Jplus, ifield )
2896
2897	have_real_field = have_real_field .OR. &
2898	( ASSOCIATED(list(ifield)%r2dptr) .OR. &
2899	ASSOCIATED(list(ifield)%r3dptr) )
2900
2901	have_int_field = have_int_field .OR. &
2902	( ASSOCIATED(list(ifield)%i2dptr) .OR. &
2903	ASSOCIATED(list(ifield)%i3dptr) )
2904
2905	END DO ! Loop over fields
2906
2907	! Main communications loop.
2908	#if defined key_mpp_mpi
2909
2910	ierr = 0
2911	maxrecvpts = MAXVAL(nrecvp(1:nrecv,1))
2912	maxsendpts = MAXVAL(nsendp(1:nsend,1))
2913	!WRITE(*,"('maxrecvpts = ',I4,' maxsendpts = ',I4)") maxrecvpts, maxsendpts
2914
2915	IF( have_real_field )THEN
2916
2917	ALLOCATE(recvBuff(maxrecvpts*nfields,nrecv),stat=ierr)
2918	!WRITE(*,"('Allocated ',I7,' reals for recv buff')") &
2919	! jpkdtamaxrecvptsnfields
2920	!!$ IF(.NOT. ALLOCATED(sendBuff))THEN
2921	!!$ ! Only allocate the sendBuff once
2922	!!$ ALLOCATE(recvBuff(jpkdtamaxrecvptsnfields,nrecv), &
2923	!!$ sendBuff(jpkdtamaxsendptsnfields,nsend),stat=ierr)
2924	!!$ WRITE(,"('Allocated ',I7,' reals for recv buff')") jpkdtamaxrecvpts*nfields
2925	!!$ WRITE(,"('Allocated ',I7,' reals for send buff')") jpkdtamaxsendpts*nfields
2926	!!$ WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)"), nfields, jpkdta
2927	!!$ ELSE
2928	!!$ ALLOCATE(recvBuff(jpkdtamaxrecvptsnfields,nrecv),stat=ierr)
2929	!!$ END IF
2930	END IF
2931
2932	IF( have_int_field .AND. (ierr == 0) )THEN
2933
2934	ALLOCATE(recvIBuff(maxrecvpts*nfields,nrecv),stat=ierr)
2935	!WRITE(*,"('Allocated ',I7,' ints for recv buff')") &
2936	! jpkdtamaxrecvptsnfields
2937
2938	!!$ IF(.NOT. ALLOCATED(sendIBuff))THEN
2939	!!$ ALLOCATE(recvIBuff(jpkdtamaxrecvptsnfields,nrecv), &
2940	!!$ sendIBuff(jpkdtamaxsendptsnfields,nsend),stat=ierr)
2941	!!$ ELSE
2942	!!$ ALLOCATE(recvIBuff(jpkdtamaxrecvptsnfields,nrecv),stat=ierr)
2943	!!$ END IF
2944	END IF
2945
2946	IF (ierr .ne. 0) THEN
2947	WRITE(,) 'ARPDBG: failed to allocate recv buf'
2948	CALL ctl_stop('STOP','exchs_generic_list: unable to allocate recv buffs')
2949	END IF
2950
2951	! Initiate receives in case posting them first improves
2952	! performance.
2953
2954	exch_flags(handle,1:nrecv,indexr) = MPI_REQUEST_NULL
2955
2956	DO irecv=1, nrecv, 1
2957
2958	r2dcount = 0
2959	r3dcount = 0
2960	i2dcount = 0
2961	i3dcount = 0
2962
2963	IF( source(irecv).GE.0 .AND. &
2964	( (nrecvp(irecv,1) > 0) .OR. (nrecvp2d(irecv,1) > 0) ) ) THEN
2965
2966	! This loop is to allow for different fields to have different
2967	! direction requirements (possibly unecessary)
2968	DO ifield=1,nfields,1
2969
2970	IF ( enabled(dirrecv(irecv), ifield) ) THEN
2971	IF( ASSOCIATED(list(ifield)%r2dptr) )THEN
2972	r2dcount = r2dcount + nrecvp2d(irecv,1)
2973	ELSE IF( ASSOCIATED(list(ifield)%i2dptr) )THEN
2974	i2dcount = i2dcount + nrecvp2d(irecv,1)
2975	ELSE IF( ASSOCIATED(list(ifield)%r3dptr) )THEN
2976	! Allow for varying size of third dimension
2977	r3dcount = r3dcount + nrecvp(irecv,1)
2978	ELSE IF( ASSOCIATED(list(ifield)%i3dptr) )THEN
2979	! Allow for varying size of third dimension
2980	i3dcount = i3dcount + nrecvp(irecv,1)
2981	END IF
2982	END IF
2983
2984	END DO
2985
2986	tag = tag_orig + dirrecv(irecv)
2987
2988	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
2989	WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") &
2990	narea-1,tag ,source(irecv), nrecvp(irecv,1)
2991	#endif
2992
2993	IF ( r2dcount > 0 .OR. r3dcount > 0 ) THEN
2994	CALL MPI_irecv (recvBuff(1,irecv),(r2dcount+r3dcount), &
2995	MPI_DOUBLE_PRECISION, source(irecv), tag, mpi_comm_opa, &
2996	exch_flags(handle,irecv,indexr), ierr)
2997	END IF
2998	IF ( i2dcount > 0 .OR. i3dcount > 0 ) THEN
2999	CALL MPI_irecv (recvIBuff(1,irecv),(i2dcount+i3dcount), &
3000	MPI_INTEGER, source(irecv),tag, mpi_comm_opa, &
3001	exch_flags(handle,irecv,indexr),ierr)
3002	END IF
3003
3004	!!$#if defined DEBUG_COMMS
3005	!!$ WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' opp dirn = ',I1,' src = ',I3,' tag = ',I4,' flag = ',I3)") &
3006	!!$ narea-1,handle,dirrecv(irecv), &
3007	!!$ opp_dirn(dirrecv(irecv)),source(irecv), &
3008	!!$ tag, exch_flags(handle,irecv,indexr)
3009	!!$#endif
3010
3011	END IF
3012
3013	ENDDO ! Loop over receives
3014
3015
3016	! Check that all sends from previous call have completed before
3017	! we continue and modify the send buffers
3018	IF (.not. first_time) THEN
3019
3020	CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr)
3021	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3022
3023	ELSE
3024	first_time = .FALSE.
3025	END IF ! .not. first_time
3026
3027	! Now allocate/reallocate SEND buffers
3028
3029	ierr = 0
3030	newSize = maxsendpts*nfields
3031	IF( have_real_field .AND. newSize > sendBuffSize)THEN
3032	sendBuffSize=newSize
3033	IF(ALLOCATED(sendBuff))DEALLOCATE(sendBuff)
3034	ALLOCATE(sendBuff(sendBuffSize,nsend),stat=ierr)
3035
3036	!WRITE(*,"('Allocated ',I7,' reals for send buff')") sendBuffSize
3037	!WRITE(*,"('nfields = ',I2,' jpkdta = ',I3)") nfields, jpkdta
3038	END IF
3039
3040	IF( have_int_field .AND. newSize > sendIBuffSize)THEN
3041	sendIBuffSize = newSize
3042	IF(ALLOCATED(sendIBuff))DEALLOCATE(sendIBuff)
3043	ALLOCATE(sendIBuff(sendIBuffSize,nsend),stat=ierr)
3044	END IF
3045
3046	IF (ierr .ne. 0) THEN
3047	CALL ctl_stop('STOP','exchs_generic_list: unable to allocate send buff')
3048	END IF
3049
3050	! Send all messages in the communications list.
3051
3052	exch_flags(handle,1:nsend,indexs) = MPI_REQUEST_NULL
3053
3054	DO isend=1, nsend, 1
3055
3056	rstart = 1
3057	istart = 1
3058	r2dcount = 0
3059	r3dcount = 0
3060	i2dcount = 0
3061	i3dcount = 0
3062
3063	IF ( destination(isend).GE.0 .AND. nxsend(isend).GT.0 ) THEN
3064
3065	! Loop over the fields for which we are going to exchange halos
3066	! and pack the data to send into a buffer
3067	DO ifield=1, nfields, 1
3068
3069	IF( enabled(dirsend(isend), ifield) )THEN
3070
3071	tag = tag_orig + dirsend(isend)
3072
3073	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3074	!!$ WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3075	!!$ narea-1, handle, tag, destination(isend),nsendp(isend,1)*XXX,dirsend(isend)
3076	!!$#endif
3077
3078	! Copy the data into the send buffer and send it. The
3079	! performance of this copy matters!
3080
3081	IF ( ASSOCIATED(list(ifield)%r2dptr) )THEN
3082
3083	ic = rstart - 1
3084
3085	pack_patches2r: DO ipatch=1, npatchsend(isend,1), 1
3086
3087	ibeg = isrcsendp(ipatch,isend,1)
3088	iend = ibeg + nxsendp(ipatch,isend,1)-1
3089	jbeg = jsrcsendp(ipatch,isend,1)
3090	jend = jbeg + nysendp(ipatch,isend,1)-1
3091
3092	DO j=jbeg, jend, 1
3093	DO i=ibeg, iend, 1
3094	ic = ic + 1
3095	sendBuff(ic, isend) = list(ifield)%r2dptr(i,j)
3096	END DO
3097	END DO
3098
3099	npacked = nxsendp(ipatch,isend,1) * &
3100	nysendp(ipatch,isend,1)
3101	rstart = rstart + npacked
3102	r2dcount = r2dcount + npacked
3103
3104	END DO pack_patches2r
3105
3106	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3107
3108	ic = istart - 1
3109
3110	pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1
3111
3112	jbeg = jsrcsendp(ipatch,isend,1)
3113	ibeg = isrcsendp(ipatch,isend,1)
3114	jend = jbeg + nysendp(ipatch,isend,1)-1
3115	iend = ibeg + nxsendp(ipatch,isend,1)-1
3116
3117	DO j=jbeg, jend, 1
3118	DO i=ibeg, iend, 1
3119	ic = ic + 1
3120	sendIBuff(ic,isend) = list(ifield)%i2dptr(i,j)
3121	END DO
3122	END DO
3123
3124	npacked = nxsendp(ipatch,isend,1) * &
3125	nysendp(ipatch,isend,1)
3126	istart = istart + npacked
3127	i2dcount = i2dcount + npacked
3128
3129	END DO pack_patches2i
3130
3131	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) )THEN
3132
3133	ic = rstart - 1
3134
3135	pack_patches3r: DO ipatch=1, npatchsend(isend,1), 1
3136
3137	! WRITE(*,"('Field = ',I2,' patch = ',I2,' ic = ',I4)") &
3138	! ifield, ipatch, ic
3139	jbeg = jsrcsendp(ipatch,isend,1)
3140	ibeg = isrcsendp(ipatch,isend,1)
3141	jend = jbeg + nysendp(ipatch,isend,1)-1
3142	iend = ibeg + nxsendp(ipatch,isend,1)-1
3143
3144	#if defined key_z_first
3145	DO j=jbeg, jend, 1
3146	DO i=ibeg, iend, 1
3147	!DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
3148	DO k=1, nzsendp(ipatch,isend,1), 1
3149	#else
3150	!DO k=1, SIZE(list(ifield)%r3dptr, index_z), 1
3151	DO k=1, nzsendp(ipatch,isend,1), 1
3152	DO j=jbeg, jend, 1
3153	DO i=ibeg, iend, 1
3154	#endif
3155	ic = ic + 1
3156	sendBuff(ic, isend) = list(ifield)%r3dptr(i,j,k)
3157	END DO
3158	END DO
3159	END DO
3160
3161	npacked = nxsendp(ipatch,isend,1) * &
3162	nysendp(ipatch,isend,1) * &
3163	nzsendp(ipatch,isend,1)
3164	rstart = rstart + npacked
3165	r3dcount = r3dcount + npacked
3166
3167	END DO pack_patches3r
3168
3169	ELSEIF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3170
3171	ic = istart - 1
3172
3173	pack_patches3i: DO ipatch = 1, npatchsend(isend, 1), 1
3174
3175	jbeg = jsrcsendp(ipatch,isend,1)
3176	ibeg = isrcsendp(ipatch,isend,1)
3177	jend = jbeg + nysendp(ipatch,isend,1)-1
3178	iend = ibeg + nxsendp(ipatch,isend,1)-1
3179
3180	#if defined key_z_first
3181	DO j=jbeg, jend, 1
3182	DO i=ibeg, iend, 1
3183	!DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
3184	DO k=1, nzsendp(ipatch,isend,1), 1
3185	#else
3186	!DO k=1, SIZE(list(ifield)%i3dptr, index_z),1
3187	DO k=1, nzsendp(ipatch,isend,1), 1
3188	DO j=jbeg, jend, 1
3189	DO i=ibeg, iend, 1
3190	#endif
3191	ic = ic + 1
3192	sendIBuff(ic, isend) = list(ifield)%i3dptr(i,j,k)
3193	END DO
3194	END DO
3195	END DO
3196
3197	npacked = nxsendp(ipatch,isend,1)* &
3198	nysendp(ipatch,isend,1)* &
3199	nzsendp(ipatch,isend,1)
3200	istart = istart + npacked
3201	i3dcount = i3dcount + npacked
3202	END DO pack_patches3i
3203
3204	ENDIF
3205
3206	#if defined DEBUG_COMMS
3207	WRITE (*,FMT="(I4,': Isend to ',I3,' has flag ',I3)") &
3208	narea-1, destination(isend), exch_flags(handle,isend,indexs)
3209	#endif
3210
3211	END IF ! Direction enabled for this field
3212
3213	END DO ! Loop over fields
3214
3215	! Now do the send(s) for all fields
3216	IF(r2dcount > 0 .OR. r3dcount > 0 )THEN
3217	CALL MPI_Isend(sendBuff(1,isend),(r2dcount+r3dcount), &
3218	MPI_DOUBLE_PRECISION, &
3219	destination(isend),tag,mpi_comm_opa, &
3220	exch_flags(handle,isend,indexs),ierr)
3221	END IF
3222	IF(i2dcount > 0 .OR. i3dcount > 0 )THEN
3223	CALL MPI_Isend(sendIBuff(1,isend),(i2dcount+i3dcount), &
3224	MPI_INTEGER, destination(isend),tag, &
3225	mpi_comm_opa, exch_flags(handle,isend,indexs),&
3226	ierr)
3227	END IF
3228
3229	ENDIF ! direction is enabled and have something to send
3230
3231	ENDDO ! Loop over sends
3232
3233	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3234	WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3235	#endif
3236
3237	! Wait on the receives that were posted earlier
3238
3239	! Copy just the set of flags we're interested in for passing to MPI_waitany
3240	exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3241
3242	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3243	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3244
3245	DO WHILE(irecv .ne. MPI_UNDEFINED)
3246
3247	istart = 1
3248	rstart = 1
3249
3250	DO ifield = 1, nfields, 1
3251
3252	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3253
3254	! Copy received data back into array
3255	ic = rstart - 1
3256	unpack_patches2r: DO ipatch=1, npatchrecv(irecv,1), 1
3257
3258	jbeg = jdesrecvp(ipatch,irecv,1)
3259	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3260	ibeg = idesrecvp(ipatch,irecv,1)
3261	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3262
3263	DO j=jbeg, jend, 1
3264	DO i=ibeg, iend, 1
3265
3266	ic = ic + 1
3267	list(ifield)%r2dptr(i,j) = recvBuff(ic,irecv)
3268	END DO
3269	END DO
3270
3271	END DO unpack_patches2r
3272
3273	! Increment starting index for next field data in buffer
3274	rstart = ic + 1 !rstart + nrecvp(irecv,1)
3275
3276	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3277
3278	! Copy received data back into array
3279	ic = istart - 1
3280	unpack_patches2i: DO ipatch = 1, npatchrecv(irecv,1), 1
3281
3282	jbeg = jdesrecvp(ipatch,irecv,1)
3283	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3284	ibeg = idesrecvp(ipatch,irecv,1)
3285	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3286
3287	DO j=jbeg, jend, 1
3288	DO i=ibeg, iend, 1
3289	ic = ic + 1
3290	list(ifield)%i2dptr(i,j) = recvIBuff(ic,irecv)
3291	END DO
3292	END DO
3293	END DO unpack_patches2i
3294
3295	! Increment starting index for next field data in buffer
3296	istart = ic + 1 !istart + nrecvp(irecv,1)
3297
3298	ELSE IF (ASSOCIATED(list(ifield)%r3dptr) ) THEN
3299
3300	ic = rstart - 1
3301	unpack_patches3r: DO ipatch=1,npatchrecv(irecv,1)
3302
3303	jbeg = jdesrecvp(ipatch,irecv,1)
3304	jend = jbeg + nyrecvp(ipatch,irecv,1)-1
3305	ibeg = idesrecvp(ipatch,irecv,1)
3306	iend = ibeg + nxrecvp(ipatch,irecv,1)-1
3307	#if defined key_z_first
3308	DO j=jbeg, jend, 1
3309	DO i=ibeg, iend, 1
3310	DO k=1, nzrecvp(ipatch,irecv,1), 1
3311	#else
3312	DO k=1, nzrecvp(ipatch,irecv,1), 1
3313	DO j=jbeg, jend, 1
3314	DO i=ibeg, iend, 1
3315	#endif
3316	ic = ic + 1
3317	list(ifield)%r3dptr(i,j,k) = recvBuff(ic,irecv)
3318	END DO
3319	END DO
3320	END DO
3321	END DO unpack_patches3r
3322
3323	! Increment starting index for next field data in buffer
3324	rstart = ic + 1 ! rstart + nrecvp(irecv,1) !*SIZE(list(ifield)%r3dptr,index_z)
3325
3326	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3327
3328	ic = istart - 1
3329	unpack_patches3i: DO ipatch=1,npatchrecv(irecv,1)
3330
3331	jbeg = jdesrecvp(ipatch,irecv,1)
3332	jend = jbeg+nyrecvp(ipatch,irecv,1)-1
3333	ibeg = idesrecvp(ipatch,irecv,1)
3334	iend = ibeg+nxrecvp(ipatch,irecv,1)-1
3335	#if defined key_z_first
3336	DO j=jbeg, jend, 1
3337	DO i=ibeg, iend, 1
3338	DO k=1,nzrecvp(ipatch,irecv,1),1
3339	#else
3340	DO k=1,nzrecvp(ipatch,irecv,1),1
3341	DO j=jbeg, jend, 1
3342	DO i=ibeg, iend, 1
3343	#endif
3344	ic = ic + 1
3345	list(ifield)%i3dptr(i,j,k) = recvIBuff(ic,irecv)
3346	END DO
3347	END DO
3348	END DO
3349	END DO unpack_patches3i
3350
3351	! Increment starting index for next field data in buffer
3352	istart = ic + 1 !istart + nrecvp(irecv,1) !*SIZE(list(ifield)%i3dptr,index_z)
3353
3354	END IF
3355
3356	END DO ! Loop over fields
3357
3358	! Wait for the next received message (if any)
3359	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3360	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3361
3362	END DO ! while irecv != MPI_UNDEFINED
3363
3364	! All receives done and unpacked - can deallocate the recv buffer now
3365	IF(ALLOCATED(recvBuff))DEALLOCATE(recvBuff)
3366	IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
3367
3368	#endif /* key_mpp_mpi */
3369
3370	! Periodic boundary condition using internal copy.
3371	! This is performed after all data has been received so that we can
3372	! also copy boundary points and avoid some diagonal communication.
3373	! Since this is just a copy we don't worry about the 'patches' of
3374	! wet points here.
3375
3376	! ARPDBG - fairly certain this code is not yet correct :-(
3377
3378	IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
3379
3380	DO ifield=1,nfields,1
3381
3382	IF ( enabled(Iplus,ifield) ) THEN
3383
3384	DO j=1,jesub+list(ifield)%halo_width
3385
3386	DO i=1,list(ifield)%halo_width
3387
3388	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3389	list(ifield)%r2dptr(iesub+i,j) = list(ifield)%r2dptr(i,j)
3390	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3391	list(ifield)%i2dptr(iesub+i,j) = list(ifield)%i2dptr(i,j)
3392	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN
3393	DO k=1,SIZE(list(ifield)%r3dptr, index_z)
3394	list(ifield)%r3dptr(iesub+i,j,k) = list(ifield)%r3dptr(i,j,k)
3395	ENDDO
3396	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3397	DO k=1,SIZE(list(ifield)%i3dptr, index_z)
3398	list(ifield)%i3dptr(iesub+i,j,k) = list(ifield)%i3dptr(i,j,k)
3399	ENDDO
3400	END IF
3401	ENDDO
3402	ENDDO
3403	END IF
3404
3405	IF ( enabled(Iminus,ifield) ) THEN
3406	!ARPDBG DO j=1,jesub,1
3407	DO j=1,jesub+list(ifield)%halo_width
3408	DO i=1, list(ifield)%halo_width
3409	IF ( ASSOCIATED(list(ifield)%r2dptr) ) THEN
3410	!ARPDBG b2(i,j) = b2(iesub-i+1,j)
3411	list(ifield)%r2dptr(i,j) = list(ifield)%r2dptr(iesub-i+1,j)
3412	ELSE IF ( ASSOCIATED(list(ifield)%i2dptr) ) THEN
3413	!ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
3414	list(ifield)%i2dptr(i,j) = list(ifield)%i2dptr(iesub-i+1,j)
3415	ELSE IF ( ASSOCIATED(list(ifield)%r3dptr) ) THEN
3416
3417	DO k=1,SIZE(list(ifield)%r3dptr,index_z),1
3418	!ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
3419	list(ifield)%r3dptr(i,j,k) = list(ifield)%r3dptr(iesub-i+1,j,k)
3420	ENDDO
3421	ELSE IF ( ASSOCIATED(list(ifield)%i3dptr) ) THEN
3422	DO k=1,SIZE(list(ifield)%i3dptr,index_z), 1
3423	!ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
3424	list(ifield)%i3dptr(i,j,k) = list(ifield)%i3dptr(iesub-i+1,j,k)
3425	END DO
3426	END IF
3427	END DO
3428	END DO
3429	END IF
3430
3431	END DO ! Loop over fields
3432	ENDIF ! cyclic_bc .AND. jpni==1
3433
3434	! Copy just the set of flags we're interested in for passing to
3435	! MPI_waitall next time around
3436	exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
3437
3438	! Free the exchange communications handle.
3439	CALL free_exch_handle(handle)
3440
3441	!CALL prof_region_end(ARPEXCHS_LIST, iprofStat)
3442
3443	END SUBROUTINE exchs_generic_list
3444
3445	! *********************************************************************
3446
3447	SUBROUTINE exchs_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
3448	handle, comm1, comm2, comm3, comm4, &
3449	cd_type, lfill)
3450
3451	! *******************************************************************
3452	! Send boundary data elements to adjacent sub-domains.
3453
3454	! b2(:,:) real input 2D real*8 local array.
3455	! ib2(:,:) int input 2D integer local array.
3456	! b3(:,:,:) real input 3D real*8 local array.
3457	! ib3(:,:,:) int input 3D integer local array.
3458	! nhalo int input Width of halo.
3459	! nhexch int input Number of halo
3460	! rows/cols to exchange.
3461	! handle int output Exchange handle.
3462	! comm1 int input Send in direction comm1.
3463	! comm2 int input Send in direction comm2.
3464	! comm3 int input Send in direction comm3.
3465	! comm4 int input Send in direction comm4.
3466	! cd_type char input Nature of array grid-points
3467	! = T , U , V , F , W points
3468	! = S : T-point, north fold treatment?
3469	! = G : F-point, north fold treatment?
3470	! lfill logical input Whether to simply fill
3471	! overlap region or apply b.c.'s
3472	!
3473	! Mike Ashworth, CCLRC, March 2005.
3474	! Andrew Porter, STFC, January 2008
3475	! *******************************************************************
3476	USE par_oce, ONLY: wp, jpreci, jprecj, jpni, jpkdta
3477	USE mapcomm_mod, ONLY: Iplus, Jplus, Iminus, Jminus, IplusJplus, &
3478	IminusJminus, IplusJminus, IminusJplus, &
3479	nrecv, nsend, nrecvp, nsendp, &
3480	nrecvp2d, nsendp2d, nxsend, nysend, &
3481	destination,dirsend, dirrecv, &
3482	isrcsend, jsrcsend, idesrecv, jdesrecv, &
3483	isrcsendp,jsrcsendp,idesrecvp,jdesrecvp, &
3484	nxrecv,source, iesub, jesub, &
3485	MaxCommDir, MaxComm, idessend, jdessend, &
3486	nxsendp, nysendp, nzsendp, &
3487	nxrecvp, nyrecvp, nzrecvp, &
3488	npatchsend, npatchrecv, cyclic_bc
3489	USE lib_mpp, ONLY: ctl_stop
3490	#if defined key_mpp_mpi
3491	USE lib_mpp, ONLY: mpi_comm_opa
3492	#endif
3493	USE dom_oce, ONLY: narea
3494	USE in_out_manager, ONLY: numout
3495	IMPLICIT none
3496
3497	! Subroutine arguments.
3498	INTEGER, INTENT(in) :: nhalo,nhexch
3499	INTEGER, INTENT(out) :: handle
3500
3501	!FTRANS b3 :I :I :z
3502	!FTRANS ib3 :I :I :z
3503	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:) :: b2
3504	INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:) :: ib2
3505	REAL(wp),OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: b3
3506	INTEGER, OPTIONAL, INTENT(inout), DIMENSION(:,:,:) :: ib3
3507
3508	INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
3509	CHARACTER(len=1), INTENT(in) :: cd_type
3510	LOGICAL, INTENT(in) :: lfill
3511
3512	! Local variables.
3513
3514	LOGICAL :: enabled(0:MaxCommDir)
3515	INTEGER :: ierr, irecv, ircvdt, isend, isnddt, &
3516	isrc, jsrc, kdim1, & ! ides, jdes, nxr, nyr, &
3517	nxs, nys, tag, tag_orig
3518	INTEGER :: maxrecvpts, maxsendpts ! Max no. of grid points involved in
3519	! any one halo exchange
3520	INTEGER :: i, j, k, ic, ipatch ! Loop counters
3521	INTEGER :: istart, iend, jstart, jend
3522	INTEGER :: index ! To hold index returned from MPI_waitany
3523	INTEGER, DIMENSION(3) :: isubsizes, istarts ! isizes
3524	#if defined key_mpp_mpi
3525	INTEGER :: status(MPI_status_size)
3526	INTEGER :: astatus(MPI_status_size,MaxComm)
3527	#endif
3528	LOGICAL, SAVE :: first_time = .TRUE.
3529	#if defined key_z_first
3530	INTEGER, PARAMETER :: index_z = 1
3531	#else
3532	INTEGER, PARAMETER :: index_z = 3
3533	#endif
3534	!!--------------------------------------------------------------------
3535
3536	#if ! defined key_mpp_rkpart
3537	RETURN
3538	#endif
3539
3540	!CALL prof_region_begin(ARPEXCHS_GENERIC, "Exchs_indiv", iprofStat)
3541	!CALL timing_start('exchs_generic')
3542
3543	ierr = 0
3544
3545	! Check nhexch is in range.
3546
3547	IF ( nhexch.GT.jpreci ) THEN
3548	CALL ctl_stop('STOP','exchs: halo width greater than maximum')
3549	ENDIF
3550
3551	! Allocate a communications tag/handle and a flags array.
3552
3553	handle = get_exch_handle()
3554	tag_orig = exch_tag(handle)
3555
3556	! Set enabled flags according to the subroutine arguments.
3557
3558	enabled(Iplus ) = .FALSE.
3559	enabled(Jplus ) = .FALSE.
3560	enabled(Iminus) = .FALSE.
3561	enabled(Jminus) = .FALSE.
3562	enabled(comm1) = comm1.GT.0
3563	enabled(comm2) = comm2.GT.0
3564	enabled(comm3) = comm3.GT.0
3565	enabled(comm4) = comm4.GT.0
3566
3567	! Set diagonal communications according to the non-diagonal flags.
3568
3569	enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
3570	enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
3571	enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
3572	enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
3573
3574	! Main communications loop.
3575	#if defined key_mpp_mpi
3576
3577	maxrecvpts = MAXVAL(nrecvp(1:nrecv,1))
3578	maxsendpts = MAXVAL(nsendp(1:nsend,1))
3579
3580	IF(PRESENT(b2) .OR. PRESENT(b3))THEN
3581	IF(.NOT. ALLOCATED(sendBuff))THEN
3582	! Only allocate the sendBuff once
3583	ALLOCATE(recvBuff(maxrecvpts,nrecv), &
3584	sendBuff(maxsendpts,nsend),stat=ierr)
3585	ELSE
3586	ALLOCATE(recvBuff(maxrecvpts,nrecv),stat=ierr)
3587	END IF
3588	ELSE IF(PRESENT(ib2) .OR. PRESENT(ib3))THEN
3589	IF(.NOT. ALLOCATED(sendIBuff))THEN
3590	ALLOCATE(recvIBuff(maxrecvpts,nrecv), &
3591	sendIBuff(maxsendpts,nsend),stat=ierr)
3592	ELSE
3593	ALLOCATE(recvIBuff(maxrecvpts,nrecv),stat=ierr)
3594	END IF
3595	END IF
3596
3597	IF (ierr .ne. 0) THEN
3598	CALL ctl_stop('STOP','exchs_generic: unable to allocate send/recvBuffs')
3599	END IF
3600
3601	! Initiate receives in case posting them first improves
3602	! performance.
3603
3604	DO irecv=1,nrecv
3605
3606	IF ( enabled(dirrecv(irecv)) .AND. &
3607	source(irecv).GE.0 .AND. nxrecv(irecv).GT.0 ) THEN
3608
3609	tag = tag_orig + dirrecv(irecv)
3610
3611	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3612	WRITE (*,FMT="(I4,': tag ',I4,' ireceiving from ',I4,' data ',I4)") narea-1,tag ,source(irecv), nrecvp(irecv,1)
3613	#endif
3614	! ARPDBG - nrecvp second rank is for multiple halo widths but
3615	! that isn't used
3616	IF ( PRESENT(b2) ) THEN
3617	CALL MPI_irecv (recvBuff(1,irecv),nrecvp2d(irecv,1), &
3618	MPI_DOUBLE_PRECISION, source(irecv), &
3619	tag, mpi_comm_opa, &
3620	exch_flags(handle,irecv,indexr), ierr)
3621	ELSEIF ( PRESENT(ib2) ) THEN
3622	CALL MPI_irecv (recvIBuff(1,irecv),nrecvp2d(irecv,1), &
3623	MPI_INTEGER, source(irecv), &
3624	tag, mpi_comm_opa, &
3625	exch_flags(handle,irecv,indexr),ierr)
3626	ELSEIF ( PRESENT(b3) ) THEN
3627	CALL MPI_irecv (recvBuff(1,irecv),nrecvp(irecv,1), &
3628	MPI_DOUBLE_PRECISION, source(irecv), &
3629	tag, mpi_comm_opa, &
3630	exch_flags(handle,irecv,indexr),ierr)
3631	ELSEIF ( PRESENT(ib3) ) THEN
3632	CALL MPI_irecv (recvIBuff(1,irecv),nrecvp(irecv,1), &
3633	MPI_INTEGER, source(irecv), &
3634	tag, mpi_comm_opa, &
3635	exch_flags(handle,irecv,indexr),ierr)
3636	ENDIF
3637	! No point checking for MPI errors because default MPI error handler
3638	! aborts run without returning control to calling program.
3639	!IF ( ierr.NE.0 ) THEN
3640	! WRITE (numout,*) 'ARPDBG - irecv hit error'
3641	! CALL flush(numout)
3642	! CALL MPI_abort(mpi_comm_opa,1,ierr)
3643	!END IF
3644
3645	#if defined DEBUG_COMMS
3646	WRITE (*,FMT="(I4,': exchs post recv : hand = ',I2,' dirn = ',I1,' src = ',I3,' tag = ',I4,' npoints = ',I6)") &
3647	narea-1,handle,dirrecv(irecv), &
3648	source(irecv), tag, nrecvp(irecv,1)
3649	#endif
3650
3651	ELSE
3652	exch_flags(handle,irecv,indexr) = MPI_REQUEST_NULL
3653	END IF
3654
3655	ENDDO
3656
3657	IF (.not. first_time) THEN
3658
3659	! Check that all sends from previous call have completed before
3660	! we continue to modify the send buffers
3661	CALL MPI_waitall(nsend, exch_flags1d, astatus, ierr)
3662	IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3663
3664	ELSE
3665	first_time = .FALSE.
3666	END IF ! .not. first_time
3667
3668
3669	! Send all messages in the communications list.
3670
3671	! CALL timing_start('mpi_sends')
3672
3673	DO isend=1,nsend
3674
3675	IF ( enabled(dirsend(isend)) .AND. &
3676	destination(isend) >= 0 .AND. nxsend(isend) > 0 ) THEN
3677
3678	isrc = isrcsend(isend)
3679	jsrc = jsrcsend(isend)
3680	nxs = nxsend(isend)
3681	nys = nysend(isend)
3682
3683	tag = tag_orig + dirsend(isend)
3684
3685	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3686	IF(PRESENT(b3))THEN
3687	WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3688	narea-1, handle, tag, destination(isend),nsendp(isend,1),dirsend(isend)
3689	ELSE IF(PRESENT(b2))THEN
3690	WRITE (*,FMT="(I4,': handle ',I4,' tag ',I4,' sending to ',I4,' data ',I4,' direction ',I3)") &
3691	narea-1, handle, tag, destination(isend),nsendp2d(isend,1),dirsend(isend)
3692	END IF
3693	#endif
3694
3695	! Copy the data into the send buffer and send it...
3696
3697	IF ( PRESENT(b2) )THEN
3698
3699	! CALL timing_start('2dr_pack')
3700	ic = 0
3701	pack_patches2r: DO ipatch=1,npatchsend(isend,1)
3702	istart = isrcsendp(ipatch,isend,1)
3703	iend = istart+nxsendp(ipatch,isend,1)-1
3704	jstart = jsrcsendp(ipatch,isend,1)
3705	jend = jstart+nysendp(ipatch,isend,1)-1
3706
3707	DO j=jstart, jend, 1
3708	DO i=istart, iend, 1
3709	ic = ic + 1
3710	sendBuff(ic,isend) = b2(i,j)
3711	END DO
3712	END DO
3713
3714	!!$ ! For 'stupid' compiler that refuses to do a memcpy for above
3715	!!$ CALL do_real8_copy( nxsendp(patch,isend,1)*nysendp(patch,isend,1), &
3716	!!$ b2(istart,jstart), &
3717	!!$ sendBuff(ic,isend) )
3718	!!$ ic = ic + nxsendp(patch,isend,1)*nysendp(patch,isend,1)
3719
3720	END DO pack_patches2r
3721
3722	! CALL timing_stop('2dr_pack')
3723
3724	CALL MPI_Isend(sendBuff(1,isend),ic,MPI_DOUBLE_PRECISION, &
3725	destination(isend),tag,mpi_comm_opa, &
3726	exch_flags(handle,isend,indexs),ierr)
3727
3728	ELSEIF ( PRESENT(ib2) ) THEN
3729
3730	ic = 0
3731	pack_patches2i: DO ipatch=1, npatchsend(isend,1), 1
3732	jstart = jsrcsendp(ipatch,isend,1)
3733	istart = isrcsendp(ipatch,isend,1)
3734	jend = jstart+nysendp(ipatch,isend,1)-1
3735	iend = istart+nxsendp(ipatch,isend,1)-1
3736
3737	DO j=jstart, jend, 1
3738	DO i=istart, iend, 1
3739	ic = ic + 1
3740	sendIBuff(ic,isend) = ib2(i,j)
3741	END DO
3742	END DO
3743	END DO pack_patches2i
3744
3745	CALL MPI_Isend(sendIBuff(1,isend),ic, MPI_INTEGER, &
3746	destination(isend),tag,mpi_comm_opa,&
3747	exch_flags(handle,isend,indexs),ierr)
3748
3749	ELSEIF ( PRESENT(b3) )THEN
3750
3751	! CALL timing_start('3dr_pack')
3752	ic = 0
3753	pack_patches3r: DO ipatch=1,npatchsend(isend,1)
3754
3755	jstart = jsrcsendp(ipatch,isend,1)
3756	istart = isrcsendp(ipatch,isend,1)
3757	jend = jstart+nysendp(ipatch,isend,1)-1
3758	iend = istart+nxsendp(ipatch,isend,1)-1
3759	#if defined key_z_first
3760	DO j=jstart, jend, 1
3761	DO i=istart, iend, 1
3762	DO k=1,nzsendp(ipatch,isend,1),1
3763	#else
3764	DO k=1,nzsendp(ipatch,isend,1),1
3765	DO j=jstart, jend, 1
3766	DO i=istart, iend, 1
3767	#endif
3768	ic = ic + 1
3769	sendBuff(ic, isend) = b3(i,j,k)
3770	END DO
3771	END DO
3772	END DO
3773	END DO pack_patches3r
3774
3775	! CALL timing_stop('3dr_pack')
3776
3777	CALL MPI_Isend(sendBuff(1,isend),ic, &
3778	MPI_DOUBLE_PRECISION, &
3779	destination(isend), tag, mpi_comm_opa, &
3780	exch_flags(handle,isend,indexs),ierr)
3781
3782	#if defined DEBUG_COMMS
3783	WRITE (*,FMT="(I4,': Isend of ',I3,' patches, ',I6,' points, to ',I3)") &
3784	narea-1, npatchsend(isend,1),ic, &
3785	destination(isend)
3786	#endif
3787
3788	ELSEIF ( PRESENT(ib3) ) THEN
3789
3790	ic = 0
3791	pack_patches3i: DO ipatch=1,npatchsend(isend,1)
3792	jstart = jsrcsendp(ipatch,isend,1) !+nhalo
3793	istart = isrcsendp(ipatch,isend,1) !+nhalo
3794	jend = jstart+nysendp(ipatch,isend,1)-1
3795	iend = istart+nxsendp(ipatch,isend,1)-1
3796	#if defined key_z_first
3797	DO j=jstart, jend, 1
3798	DO i=istart, iend, 1
3799	DO k=1,nzsendp(ipatch,isend,1),1
3800	#else
3801	DO k=1,nzsendp(ipatch,isend,1),1
3802	DO j=jstart, jend, 1
3803	DO i=istart, iend, 1
3804	#endif
3805	ic = ic + 1
3806	sendIBuff(ic, isend) = ib3(i,j,k)
3807	END DO
3808	END DO
3809	END DO
3810	END DO pack_patches3i
3811
3812	CALL MPI_Isend(sendIBuff(1,isend),ic, &
3813	MPI_INTEGER, &
3814	destination(isend),tag,mpi_comm_opa, &
3815	exch_flags(handle,isend,indexs),ierr)
3816	ENDIF
3817
3818	!IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3819
3820	ELSE
3821
3822	exch_flags(handle,isend,indexs) = MPI_REQUEST_NULL
3823
3824	ENDIF ! direction is enabled and have something to send
3825
3826	ENDDO ! Loop over sends
3827
3828	! CALL timing_stop('mpi_sends')
3829
3830	#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
3831	WRITE (*,FMT="(I3,': exch tag ',I4,' finished all sends')") narea-1,tag
3832	#endif
3833
3834	! Wait on the receives that were posted earlier
3835
3836	! CALL timing_start('mpi_recvs')
3837
3838	! Copy just the set of flags we're interested in for passing
3839	! to MPI_waitany
3840	exch_flags1d(1:nrecv) = exch_flags(handle, 1:nrecv, indexr)
3841
3842	#if defined DEBUG_COMMS
3843	WRITE(*,"(I3,': Doing waitany: nrecv =',I3,' handle = ',I3)") &
3844	narea-1, nrecv,handle
3845	#endif
3846
3847	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3848	IF ( ierr .NE. MPI_SUCCESS ) THEN
3849
3850	IF(ierr .EQ. MPI_ERR_REQUEST)THEN
3851	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_REQUEST')") narea-1
3852	ELSE IF(ierr .EQ. MPI_ERR_ARG)THEN
3853	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned MPI_ERR_ARG')") narea-1
3854	ELSE
3855	WRITE (*,"(I3,': ERROR: exchs_generic: MPI_waitany returned unrecognised error')") narea-1
3856	END IF
3857	CALL ctl_stop('STOP','exchs_generic: MPI_waitany returned error')
3858	END IF
3859
3860	DO WHILE(irecv .ne. MPI_UNDEFINED)
3861
3862	IF ( PRESENT(b2) ) THEN
3863
3864	! CALL timing_start('2dr_unpack')
3865
3866	! Copy received data back into array
3867	ic = 0
3868	unpack_patches2r: DO ipatch=1,npatchrecv(irecv,nhexch)
3869
3870	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3871	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3872	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3873	iend = istart+nxrecvp(ipatch,irecv,1)-1
3874	DO j=jstart, jend, 1
3875	DO i=istart, iend, 1
3876	ic = ic + 1
3877	b2(i,j) = recvBuff(ic,irecv)
3878	END DO
3879	END DO
3880	END DO unpack_patches2r
3881
3882	! CALL timing_stop('2dr_unpack')
3883
3884	ELSE IF ( PRESENT(ib2) ) THEN
3885
3886	! Copy received data back into array
3887	ic = 0
3888	unpack_patches2i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3889
3890	jstart = jdesrecvp(ipatch,irecv,1)
3891	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3892	istart = idesrecvp(ipatch,irecv,1)
3893	iend = istart+nxrecvp(ipatch,irecv,1)-1
3894	DO j=jstart, jend, 1
3895	DO i=istart, iend, 1
3896	ic = ic + 1
3897	ib2(i,j) = recvIBuff(ic,irecv)
3898	END DO
3899	END DO
3900	END DO unpack_patches2i
3901
3902	ELSE IF (PRESENT(b3) ) THEN
3903
3904	! CALL timing_start('3dr_unpack')
3905	ic = 0
3906	unpack_patches3r: DO ipatch=1,npatchrecv(irecv,nhexch)
3907
3908	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3909	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3910	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3911	iend = istart+nxrecvp(ipatch,irecv,1)-1
3912	#if defined key_z_first
3913	DO j=jstart, jend, 1
3914	DO i=istart, iend, 1
3915	DO k=1,nzrecvp(ipatch,irecv,1),1
3916	#else
3917	DO k=1,nzrecvp(ipatch,irecv,1),1
3918	DO j=jstart, jend, 1
3919	DO i=istart, iend, 1
3920	#endif
3921	ic = ic + 1
3922	b3(i,j,k) = recvBuff(ic,irecv)
3923	END DO
3924	#if defined key_z_first
3925	! ARPDBG - wipe anything below the ocean bottom
3926	DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3927	b3(i,j,k) = 0.0_wp
3928	END DO
3929	#endif
3930	END DO
3931	END DO
3932
3933	! ARPDBG - wipe anything below the ocean bottom
3934	#if ! defined key_z_first
3935	DO k=nzrecvp(ipatch,irecv,1)+1,jpk,1
3936	DO j=jstart, jend, 1
3937	DO i=istart, iend, 1
3938	b3(i,j,k) = 0.0_wp
3939	END DO
3940	END DO
3941	END DO
3942	#endif
3943
3944	END DO unpack_patches3r
3945
3946	! CALL timing_stop('3dr_unpack')
3947
3948	ELSEIF ( PRESENT(ib3) ) THEN
3949
3950	ic = 0
3951	unpack_patches3i: DO ipatch=1,npatchrecv(irecv,nhexch),1
3952
3953	jstart = jdesrecvp(ipatch,irecv,1)!+nhalo
3954	jend = jstart+nyrecvp(ipatch,irecv,1)-1
3955	istart = idesrecvp(ipatch,irecv,1)!+nhalo
3956	iend = istart+nxrecvp(ipatch,irecv,1)-1
3957	#if defined key_z_first
3958	DO j=jstart, jend, 1
3959	DO i=istart, iend, 1
3960	DO k=1,nzrecvp(ipatch,irecv,1),1
3961	#else
3962	DO k=1,nzrecvp(ipatch,irecv,1),1
3963	DO j=jstart, jend, 1
3964	DO i=istart, iend, 1
3965	#endif
3966	ic = ic + 1
3967	ib3(i,j,k) = recvIBuff(ic,irecv)
3968	END DO
3969	END DO
3970	END DO
3971	END DO unpack_patches3i
3972
3973	END IF
3974
3975	CALL MPI_waitany (nrecv, exch_flags1d, irecv, status, ierr)
3976	!IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
3977
3978	END DO ! while irecv != MPI_UNDEFINED
3979
3980	! CALL timing_stop('mpi_recvs')
3981
3982	! All receives done and unpacked so can deallocate the associated
3983	! buffers
3984	!IF(ALLOCATED(recvBuff ))DEALLOCATE(recvBuff)
3985	!IF(ALLOCATED(recvIBuff))DEALLOCATE(recvIBuff)
3986
3987	#if defined DEBUG_COMMS
3988	WRITE(*,"(I3,': Finished all ',I3,' receives for handle ',I3)") &
3989	narea-1, nrecv, handle
3990	#endif
3991
3992	#endif /* key_mpp_mpi */
3993
3994	! Periodic boundary condition using internal copy.
3995	! This is performed after all data has been received so that we can
3996	! also copy boundary points and avoid some diagonal communication.
3997	!
3998	! ARPDBG - performance issue: need to hoist IF block outside nested
3999	! loop!
4000	IF ( cyclic_bc .AND. (jpni.EQ.1) ) THEN
4001
4002	! Find out the sizes of the arrays.
4003	kdim1 = 1
4004	IF ( PRESENT(b3) ) THEN
4005	kdim1 = SIZE(b3,dim=index_z)
4006	ELSEIF ( PRESENT(ib3) ) THEN
4007	kdim1 = SIZE(ib3,dim=index_z)
4008	ENDIF
4009
4010
4011	IF ( enabled(Iplus) ) THEN
4012	!ARPDBG DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4013	DO j=1,jesub+jpreci
4014	!ARPDBG DO i=nhexch,1,-1
4015	DO i=1,jpreci
4016	IF ( PRESENT(b2) ) THEN
4017	!ARPDBG b2(iesub-i+1,j) = b2(i,j)
4018	b2(iesub+i,j) = b2(i,j)
4019	ELSEIF ( PRESENT(ib2) ) THEN
4020	!ARPDBG ib2(iesub-i+1,j) = ib2(i,j)
4021	ib2(iesub+i,j) = ib2(i,j)
4022	ELSEIF ( PRESENT(b3) ) THEN
4023	! dir$ unroll
4024	DO k=1,kdim1
4025	!ARPDBG b3(k,iesub-i+1,j) = b3(k,i,j)
4026	b3(k,iesub+i,j) = b3(k,i,j)
4027	ENDDO
4028	ELSEIF ( PRESENT(ib3) ) THEN
4029	! dir$ unroll
4030	DO k=1,kdim1
4031	!ARPDBG ib3(k,iesub-i+1,j) = ib3(k,i,j)
4032	ib3(k,iesub+i,j) = ib3(k,i,j)
4033	ENDDO
4034	ENDIF
4035	ENDDO
4036	ENDDO
4037	ENDIF
4038
4039	IF ( enabled(Iminus) ) THEN
4040	!ARPDBG DO j=1,jesub,1
4041	DO j=1,jesub+jpreci
4042	DO i=1,jpreci
4043	IF ( PRESENT(b2) ) THEN
4044	!ARPDBG b2(i,j) = b2(iesub-i+1,j)
4045	b2(1-i,j) = b2(iesub-i+1,j)
4046	ELSEIF ( PRESENT(ib2) ) THEN
4047	!ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
4048	ib2(1-i,j) = ib2(iesub-i+1,j)
4049	ELSEIF ( PRESENT(b3) ) THEN
4050	! dir$ unroll
4051	DO k=1,kdim1
4052	!ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
4053	b3(1-i,j,k) = b3(iesub-i+1,j,k)
4054	ENDDO
4055	ELSEIF ( PRESENT(ib3) ) THEN
4056	! dir$ unroll
4057	DO k=1,kdim1
4058	!ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
4059	ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4060	ENDDO
4061	ENDIF
4062	ENDDO
4063	ENDDO
4064	ENDIF
4065
4066	ENDIF ! cyclic_bc .AND. jpni == 1
4067
4068	! Copy just the set of flags we're interested in for passing to
4069	! MPI_waitall next time around
4070	exch_flags1d(1:nsend) = exch_flags(handle, 1:nsend, indexs)
4071
4072	! Free the exchange communications handle.
4073	CALL free_exch_handle(handle)
4074
4075	! All receives done so we can safely free the MPI receive buffers
4076	IF( ALLOCATED(recvBuff) ) DEALLOCATE(recvBuff)
4077	IF( ALLOCATED(recvIBuff) )DEALLOCATE(recvIBuff)
4078
4079	! CALL timing_stop('exchs_generic')
4080	!CALL prof_region_end(ARPEXCHS_GENERIC, iprofStat)
4081
4082	END SUBROUTINE exchs_generic
4083
4084	! ********************************************************************
4085
4086	!!$ SUBROUTINE exchr_generic ( b2, ib2, b3, ib3, nhalo, nhexch, &
4087	!!$ handle, comm1, comm2, comm3, comm4 )
4088	!!$
4089	!!$ ! ******************************************************************
4090	!!$
4091	!!$ ! Receive boundary data elements from adjacent sub-domains.
4092	!!$
4093	!!$ ! b2(1-nhalo:,1-nhalo:) real input 2D real*8 local array.
4094	!!$ ! ib2(1-nhalo:,1-nhalo:) int input 2D integer local array.
4095	!!$ ! b3(:,1-nhalo:,1-nhalo:) real input 3D real*8 local array.
4096	!!$ ! ib3(:,1-nhalo:,1-nhalo:) int input 3D integer local array.
4097	!!$ ! nhalo int input Width of halo.
4098	!!$ ! nhexch int input Number of halo
4099	!!$ ! rows/cols to exchange.
4100	!!$ ! handle int input Exchange handle.
4101	!!$ ! comm1 int input Send in direction comm1.
4102	!!$ ! comm2 int input Send in direction comm2.
4103	!!$ ! comm3 int input Send in direction comm3.
4104	!!$ ! comm4 int input Send in direction comm4.
4105	!!$
4106	!!$ ! Mike Ashworth, CCLRC, March 2005.
4107	!!$
4108	!!$ ! ******************************************************************
4109	!!$ USE mapcomm_mod, ONLY: iesub,jesub,MaxCommDir,Iplus,Jplus,Iminus, &
4110	!!$ Jminus, IplusJplus,IminusJminus,IplusJminus, &
4111	!!$ IminusJplus, nrecv, nxrecv,nyrecv, source, dirrecv, &
4112	!!$ idesrecv, jdesrecv, cyclic_bc, destination, &
4113	!!$ nsend, nxsend, dirsend
4114	!!$ !ARPDBG: do_exchanges below is debug only
4115	!!$ USE par_oce, ONLY: jpni, jpreci, wp, do_exchanges
4116	!!$ USE lib_mpp, ONLY: mpi_comm_opa
4117	!!$ USE dom_oce, ONLY: narea
4118	!!$#ifdef WITH_LIBHMD
4119	!!$ USE in_out_manager, ONLY: lwp
4120	!!$#endif
4121	!!$ IMPLICIT NONE
4122	!!$
4123	!!$ INTEGER :: status(MPI_status_size)
4124	!!$
4125	!!$ ! Subroutine arguments.
4126	!!$!xxFTRANS b3 :I :I :z
4127	!!$!xxFTRANS ib3 :I :I :z
4128	!!$ INTEGER, INTENT(In) :: nhalo,nhexch,handle
4129	!!$ REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:) :: b2
4130	!!$ INTEGER, INTENT(inout), OPTIONAL, DIMENSION(:,:) :: ib2
4131	!!$ REAL(wp), INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: b3
4132	!!$ INTEGER, INTENT(inout), OPTIONAL, DIMENSION(:,:,:) :: ib3
4133	!!$ INTEGER, INTENT(in) :: comm1, comm2, comm3, comm4
4134	!!$
4135	!!$ ! Local variables.
4136	!!$
4137	!!$ LOGICAL :: enabled(0:MaxCommDir)
4138	!!$ INTEGER :: i, ides, ierr, irecv, isend, j, jdes, k, &
4139	!!$ kdim1, nxr, nyr
4140	!!$
4141	!!$#ifdef PARALLEL_STATS
4142	!!$ LOGICAL :: probe
4143	!!$ INTEGER :: nbpw
4144	!!$#endif
4145	!!$
4146	!!$ IF(.not. do_exchanges)THEN
4147	!!$ WRITE (,) 'ARPDBG: exchr_generic: do_exchanges is FALSE'
4148	!!$ RETURN ! ARPDBG
4149	!!$ END IF
4150	!!$
4151	!!$#ifdef PARALLEL_STATS
4152	!!$ IF ( PRESENT(b2) .OR. PRESENT(b3) ) THEN
4153	!!$ nbpw = 8
4154	!!$ ELSE
4155	!!$ nbpw = nbpi
4156	!!$ ENDIF
4157	!!$#endif
4158	!!$
4159	!!$ ! Find out the sizes of the arrays.
4160	!!$
4161	!!$ kdim1 = 1
4162	!!$ IF ( PRESENT(b3) ) THEN
4163	!!$!! DCSE_NEMO - bug here in original code?
4164	!!$! Code used to say kdim1 = SIZE(b3,dim=1) whereas ARP thinks it should
4165	!!$! have had dim=3. Ditto for ib3 below.
4166	!!$#if defined key_z_first
4167	!!$ kdim1 = SIZE(b3,dim=1)
4168	!!$#else
4169	!!$ kdim1 = SIZE(b3,dim=3)
4170	!!$#endif
4171	!!$! isizes(3) = kdim1
4172	!!$! isizes(2) = SIZE(b3,dim=2)
4173	!!$! isizes(1) = SIZE(b3,dim=1)
4174	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4175	!!$#if defined key_z_first
4176	!!$ kdim1 = SIZE(ib3,dim=1)
4177	!!$#else
4178	!!$ kdim1 = SIZE(ib3,dim=3)
4179	!!$#endif
4180	!!$! isizes(3) = kdim1
4181	!!$! isizes(2) = SIZE(ib3,dim=2)
4182	!!$! isizes(1) = SIZE(ib3,dim=1)
4183	!!$ ENDIF
4184	!!$
4185	!!$ ! Check nhexch is in range.
4186	!!$
4187	!!$ IF ( nhexch.GT.jpreci ) THEN
4188	!!$ STOP 'exchr: halo width greater than maximum'
4189	!!$ ENDIF
4190	!!$
4191	!!$ ! Set enabled flags according to the subroutine arguments.
4192	!!$
4193	!!$ enabled(Iplus ) = .FALSE.
4194	!!$ enabled(Jplus ) = .FALSE.
4195	!!$ enabled(Iminus) = .FALSE.
4196	!!$ enabled(Jminus) = .FALSE.
4197	!!$ enabled(comm1) = comm1.GT.0
4198	!!$ enabled(comm2) = comm2.GT.0
4199	!!$ enabled(comm3) = comm3.GT.0
4200	!!$ enabled(comm4) = comm4.GT.0
4201	!!$
4202	!!$ ! Set diagonal communications according to the non-diagonal flags.
4203	!!$
4204	!!$ enabled(IplusJplus ) = enabled(Iplus ).AND.enabled(Jplus )
4205	!!$ enabled(IminusJminus)= enabled(Iminus).AND.enabled(Jminus)
4206	!!$ enabled(IplusJminus) = enabled(Iplus ).AND.enabled(Jminus)
4207	!!$ enabled(IminusJplus )= enabled(Iminus).AND.enabled(Jplus )
4208	!!$
4209	!!$ ! Main communications loop.
4210	!!$
4211	!!$ ! Receive all messages in the communications list.
4212	!!$
4213	!!$ DO irecv=1,nrecv
4214	!!$
4215	!!$ IF ( enabled(dirrecv(irecv)) .AND. source(irecv).GE.0 &
4216	!!$! .AND. nxrecv(irecv,nhexch).GT.0 ) THEN
4217	!!$ .AND. nxrecv(irecv).GT.0 ) THEN
4218	!!$
4219	!!$! ides = idesrecv(irecv,nhexch)
4220	!!$! jdes = jdesrecv(irecv,nhexch)
4221	!!$! nxr = nxrecv(irecv,nhexch)
4222	!!$! nyr = nyrecv(irecv,nhexch)
4223	!!$ ides = idesrecv(irecv)
4224	!!$ jdes = jdesrecv(irecv)
4225	!!$ nxr = nxrecv(irecv)
4226	!!$ nyr = nyrecv(irecv)
4227	!!$
4228	!!$ ! Wait on the receives that were actually posted in the send routine
4229	!!$
4230	!!$#if ( defined DEBUG && defined DEBUG_EXCHANGE ) \|\| defined DEBUG_COMMS
4231	!!$ WRITE (*,FMT="(I4,': test for recv from ',I3,' data ',I3,' x ',I3,' to ',I3,I3)") narea-1,source(irecv),nxr,nyr,ides,jdes
4232	!!$ WRITE (*,FMT="(I4,': test flag = ',I3)") narea-1, &
4233	!!$ exch_flags(handle,irecv,indexr)
4234	!!$#endif
4235	!!$
4236	!!$#ifdef PARALLEL_STATS
4237	!!$ CALL MPI_test (exch_flags(handle,irecv,indexr),probe,status,ierr)
4238	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4239	!!$ IF ( .NOT.probe ) THEN
4240	!!$ nmwait = nmwait+1
4241	!!$ ENDIF
4242	!!$#endif /* PARALLEL_STATS */
4243	!!$ CALL MPI_wait (exch_flags(handle,irecv,indexr),status,ierr)
4244	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4245	!!$
4246	!!$#ifdef PARALLEL_STATS
4247	!!$ nmrecv = nmrecv + 1
4248	!!$ nbrecv = nbrecv + kdim1nbpwnxr*nyr
4249	!!$
4250	!!$#endif /* PARALLEL_STATS */
4251	!!$ ENDIF
4252	!!$
4253	!!$ ENDDO
4254	!!$
4255	!!$ ! Periodic boundary condition using internal copy.
4256	!!$ ! This is performed after all data has been received so that we can
4257	!!$ ! also copy boundary points and avoid some diagonal communication.
4258	!!$
4259	!!$ IF ( cyclic_bc .AND. jpni.EQ.1 ) THEN
4260	!!$
4261	!!$ IF ( enabled(Iplus) ) THEN
4262	!!$ !ARPDBG DO j=1,jesub,1 ! ARPDBG - nemo halos included in jesub
4263	!!$!ARPDBG - broken? Loop over j is used as 3rd index in 3D arrays
4264	!!$!ARPDBG but kdim1 is correctly(?) set to extent of first dimension
4265	!!$ DO j=1,jesub+jpreci
4266	!!$ !ARPDBG DO i=nhexch,1,-1
4267	!!$ DO i=1,jpreci
4268	!!$ IF ( PRESENT(b2) ) THEN
4269	!!$ !ARPDBG b2(iesub-i+1,j) = b2(i,j)
4270	!!$ b2(iesub+i,j) = b2(i,j)
4271	!!$ ELSEIF ( PRESENT(ib2) ) THEN
4272	!!$ !ARPDBG ib2(iesub-i+1,j) = ib2(i,j)
4273	!!$ ib2(iesub+i,j) = ib2(i,j)
4274	!!$ ELSEIF ( PRESENT(b3) ) THEN
4275	!!$ ! dir$ unroll
4276	!!$ DO k=1,kdim1
4277	!!$ !ARPDBG b3(k,iesub-i+1,j) = b3(k,i,j)
4278	!!$ b3(k,iesub+i,j) = b3(k,i,j)
4279	!!$ ENDDO
4280	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4281	!!$ ! dir$ unroll
4282	!!$ DO k=1,kdim1
4283	!!$ !ARPDBG ib3(k,iesub-i+1,j) = ib3(k,i,j)
4284	!!$ ib3(k,iesub+i,j) = ib3(k,i,j)
4285	!!$ ENDDO
4286	!!$ ENDIF
4287	!!$ ENDDO
4288	!!$ ENDDO
4289	!!$ ENDIF
4290	!!$
4291	!!$ IF ( enabled(Iminus) ) THEN
4292	!!$ !ARPDBG DO j=1,jesub,1
4293	!!$ DO j=1,jesub+jpreci
4294	!!$ DO i=1,jpreci
4295	!!$ IF ( PRESENT(b2) ) THEN
4296	!!$ !ARPDBG b2(i,j) = b2(iesub-i+1,j)
4297	!!$ b2(1-i,j) = b2(iesub-i+1,j)
4298	!!$ ELSEIF ( PRESENT(ib2) ) THEN
4299	!!$ !ARPDBG ib2(i,j) = ib2(iesub-i+1,j)
4300	!!$ ib2(1-i,j) = ib2(iesub-i+1,j)
4301	!!$ ELSEIF ( PRESENT(b3) ) THEN
4302	!!$ ! dir$ unroll
4303	!!$ DO k=1,kdim1
4304	!!$ !ARPDBG b3(k,i,j) = b3(k,iesub-i+1,j)
4305	!!$ b3(1-i,j,k) = b3(iesub-i+1,j,k)
4306	!!$ ENDDO
4307	!!$ ELSEIF ( PRESENT(ib3) ) THEN
4308	!!$ ! dir$ unroll
4309	!!$ DO k=1,kdim1
4310	!!$ !ARPDBG ib3(k,i,j) = ib3(k,iesub-i+1,j)
4311	!!$ ib3(1-i,j,k) = ib3(iesub-i+1,j,k)
4312	!!$ ENDDO
4313	!!$ ENDIF
4314	!!$ ENDDO
4315	!!$ ENDDO
4316	!!$ ENDIF
4317	!!$
4318	!!$ ENDIF
4319	!!$
4320	!!$ IF ( immed ) THEN
4321	!!$
4322	!!$ ! Check completion for immediate sends.
4323	!!$
4324	!!$ DO isend=1,nsend
4325	!!$
4326	!!$ IF (enabled(dirsend(isend)) .AND. &
4327	!!$ destination(isend).GE.0 .AND. nxsend(isend,nhexch).GT.0 ) THEN
4328	!!$
4329	!!$ CALL MPI_wait (exch_flags(handle,isend,indexs),status,ierr)
4330	!!$ IF ( ierr.NE.0 ) CALL MPI_abort(mpi_comm_opa,1,ierr)
4331	!!$
4332	!!$ ENDIF
4333	!!$
4334	!!$ ENDDO
4335	!!$
4336	!!$ ENDIF
4337	!!$
4338	!!$ ! Free the exchange communications handle.
4339	!!$
4340	!!$ CALL free_exch_handle(handle)
4341	!!$
4342	!!$ END SUBROUTINE exchr_generic
4343
4344	!=======================================================================
4345
4346	SUBROUTINE mpp_lbc_north_list(list, nfields)
4347	USE par_oce, ONLY : jpni, jpi, jpj
4348	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
4349	nwidthmax
4350	USE mapcomm_mod, ONLY : pielb, piesub
4351	USE lib_mpp, ONLY : ctl_stop
4352	IMPLICIT none
4353	! Subroutine arguments.
4354	TYPE (exch_item), DIMENSION(:), INTENT(inout) :: list
4355	INTEGER, INTENT(in) :: nfields
4356
4357	!! * Local declarations
4358	INTEGER :: ijpj ! No. of rows to operate upon
4359	INTEGER :: ii, ji, jj, jk, jji, jjr, jr, jproc, klimit
4360	INTEGER :: ierr, ifield, ishifti, ishiftr
4361	INTEGER :: ildi,ilei,iilb
4362	INTEGER :: ij,ijt,iju, isgn
4363	INTEGER :: itaille
4364	!FTRANS ztab :I :I :z
4365	!FTRANS iztab :I :I :z
4366	!FTRANS znorthgloio :I :I :z :
4367	!FTRANS iznorthgloio :I :I :z :
4368	!FTRANS znorthloc :I :I :z
4369	!FTRANS iznorthloc :I :I :z
4370	INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: iztab
4371	INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: iznorthgloio
4372	INTEGER, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: iznorthloc
4373	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ztab
4374	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio
4375	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthloc
4376	REAL(wp) :: psgn ! control of the sign change
4377	LOGICAL :: field_is_real, fields_all_real, fields_all_int
4378	LOGICAL :: fields_all_3d, fields_all_2d
4379	!!----------------------------------------------------------------------
4380
4381	CALL prof_region_begin(ARPNORTHLISTCOMMS, "NorthList", iprofStat)
4382
4383	#if defined key_mpp_mpi
4384
4385	! If we get into this routine it's because : North fold condition and mpp
4386	! with more than one PE across i : we deal only with the North condition
4387
4388	! Set no. of rows from a module parameter that is also used in exchtestmod
4389	! and mpp_ini_north
4390	ijpj = num_nfold_rows
4391
4392	! Allocate work-space arrays
4393	IF(.not. ALLOCATED(ztab))THEN
4394
4395	ALLOCATE(ztab(jpiglo,maxExchItems*ijpj,jpk), &
4396	iztab(jpiglo,maxExchItems*ijpj,jpk), &
4397	znorthgloio(nwidthmax,maxExchItems*ijpj,jpk,jpni), &
4398	znorthloc(nwidthmax,maxExchItems*ijpj,jpk), &
4399	iznorthgloio(nwidthmax,maxExchItems*ijpj,jpk,jpni), &
4400	iznorthloc(nwidthmax,maxExchItems*ijpj,jpk), &
4401	STAT=ierr)
4402	IF(ierr .ne. 0)THEN
4403	CALL ctl_stop('STOP','mpp_lbc_north_list: memory allocation failed')
4404	RETURN
4405	END IF
4406	END IF
4407
4408	! put the last ijpj jlines of each real field into znorthloc
4409	! znorthloc(:,:,:) = 0_wp ! because of padding for nwidthmax
4410	! iznorthloc(:,:,:) = 0
4411	ishiftr = 0
4412	ishifti = 0
4413	fields_all_real = .TRUE.
4414	fields_all_int = .TRUE.
4415	fields_all_3d = .TRUE.
4416	fields_all_2d = .TRUE.
4417
4418	CALL prof_region_begin(NORTHLISTGATHER, "NorthListGather", iprofStat)
4419
4420	DO ifield=1,nfields,1
4421
4422	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
4423	DO ij = 1, ijpj, 1
4424	jj = nlcj - ijpj + ij
4425	znorthloc(nldi:nlei,ij+ishiftr,1) = &
4426	list(ifield)%r2dptr(nldi:nlei,jj)
4427	END DO
4428
4429	ishiftr = ishiftr + ijpj
4430	fields_all_int = .FALSE.
4431	fields_all_3d = .FALSE.
4432	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
4433
4434	#if defined key_z_first
4435	DO ij = 1, ijpj, 1
4436	jj = nlcj - ijpj + ij
4437	DO ii = nldi, nlei, 1
4438	DO jk = 1, jpk
4439	#else
4440	DO jk = 1, jpk
4441	DO ij = 1