New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

exchmod.F90 in branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

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

Last change on this file since 3837 was 3837, checked in by trackstand2, 11 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, ijpj, 1
4442	jj = nlcj - ijpj + ij
4443	DO ii = nldi, nlei, 1
4444	#endif
4445	znorthloc(ii,ij+ishiftr,jk) = &
4446	list(ifield)%r3dptr(ii,jj,jk)
4447	END DO
4448	END DO
4449	END DO
4450
4451	ishiftr = ishiftr + ijpj
4452	fields_all_int = .FALSE.
4453	fields_all_2d = .FALSE.
4454	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
4455
4456	DO ij = 1, ijpj, 1
4457	jj = nlcj - ijpj + ij
4458	iznorthloc(nldi:nlei,ij+ishifti,1) = &
4459	list(ifield)%i2dptr(nldi:nlei,jj)
4460	END DO
4461
4462	ishifti = ishifti + ijpj
4463	fields_all_real = .FALSE.
4464	fields_all_3d = .FALSE.
4465	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
4466
4467	#if defined key_z_first
4468	DO ij = 1, ijpj, 1
4469	jj = nlcj - ijpj + ij
4470	DO ii = nldi, nlei, 1
4471	DO jk = 1, jpk
4472	#else
4473	DO jk = 1, jpk
4474	DO ij = 1, ijpj, 1
4475	jj = nlcj - ijpj + ij
4476	DO ii = nldi, nlei, 1
4477	#endif
4478	iznorthloc(ii,ij+ishifti,jk) = &
4479	list(ifield)%i3dptr(ii,jj,jk)
4480	END DO
4481	END DO
4482	END DO
4483
4484	ishifti = ishifti + ijpj
4485	fields_all_real = .FALSE.
4486	fields_all_2d = .FALSE.
4487	END IF
4488
4489	END DO ! loop over fields
4490
4491	klimit = 1
4492	IF(.not. fields_all_2d)klimit = jpk
4493
4494	IF (npolj /= 0 ) THEN
4495	IF(.NOT. fields_all_int )THEN
4496	! Build znorthgloio on proc 0 of ncomm_north
4497	!znorthgloio(:,:,:,:) = 0_wp
4498	itaille=nwidthmaxishiftrklimit
4499	#if defined key_mpp_mpi
4500	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, &
4501	znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
4502	0, ncomm_north, ierr)
4503	#endif
4504	END IF
4505	IF(.NOT. fields_all_real )THEN
4506	! Build iznorthgloio on proc 0 of ncomm_north
4507	!iznorthgloio(:,:,:,:) = 0
4508	itaille=nwidthmaxishiftiklimit
4509	#if defined key_mpp_mpi
4510	CALL MPI_GATHER(iznorthloc,itaille,MPI_INTEGER, &
4511	iznorthgloio,itaille,MPI_INTEGER,&
4512	0, ncomm_north, ierr)
4513	#endif
4514	END IF
4515	ENDIF
4516
4517	CALL prof_region_end(NORTHLISTGATHER, iprofStat)
4518
4519	CALL prof_region_begin(ARPNORTHAPPLYSYMM, "NorthListApplySymm", iprofStat)
4520
4521	IF (narea == north_root+1 ) THEN
4522	! recover the global north array for every field
4523	! ztab(:,:,:) = 0_wp
4524	! iztab(:,:,:) = 0_wp
4525
4526	IF( .NOT. fields_all_int )THEN
4527
4528	DO jr = 1, ndim_rank_north
4529	jproc = nrank_north(jr) + 1
4530	ildi = nldit (jproc)
4531	ilei = nleit (jproc)
4532	iilb = pielb(jproc)
4533	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:jpk) = &
4534	znorthgloio(ildi:ilei,1:ishiftr,1:jpk,jr)
4535	END DO
4536	END IF
4537	IF( .NOT. fields_all_real )THEN
4538
4539	DO jr = 1, ndim_rank_north
4540	jproc = nrank_north(jr) + 1
4541	ildi = nldit (jproc)
4542	ilei = nleit (jproc)
4543	iilb = pielb(jproc)
4544	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:jpk) = &
4545	iznorthgloio(ildi:ilei,1:ishifti,1:jpk,jr)
4546	END DO
4547	END IF
4548
4549	! Horizontal slab
4550	! ===============
4551
4552	jji = ijpj
4553	jjr = ijpj
4554
4555	! 2. North-Fold boundary conditions
4556	! ----------------------------------
4557
4558	SELECT CASE ( npolj )
4559
4560	CASE ( 3, 4 ) ! * North fold T-point pivot
4561
4562	DO ifield=1, nfields, 1
4563
4564	! Set-up stuff dependent on whether this field is real or integer
4565	field_is_real = .FALSE.
4566	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4567	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
4568
4569	isgn = list(ifield)%isgn
4570	psgn = REAL(isgn, wp)
4571
4572	! Set up stuff dependent on whether this field is 2- or 3-dimensional
4573	IF(fields_all_3d)THEN
4574	klimit=jpk
4575	ELSE IF(fields_all_2d)THEN
4576	klimit = 1
4577	ELSE
4578	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4579	ASSOCIATED(list(ifield)%i3dptr) )THEN
4580	klimit=jpk
4581	ELSE
4582	klimit = 1
4583	END IF
4584	END IF
4585
4586	IF(field_is_real)THEN
4587	ztab( 1 , jjr, 1:klimit) = 0._wp
4588	ztab(jpiglo, jjr, 1:klimit) = 0._wp
4589	ELSE
4590	iztab( 1 , jji, 1:klimit) = 0
4591	iztab(jpiglo, jji, 1:klimit) = 0
4592	END IF
4593
4594	SELECT CASE ( list(ifield)%grid )
4595
4596	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
4597
4598	IF(field_is_real)THEN
4599	#if defined key_z_first
4600	DO ji = 2, jpiglo/2
4601	ijt = jpiglo-ji+2
4602	DO jk = 1,klimit,1
4603	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4604	END DO
4605	END DO
4606	DO ji = jpiglo/2+1, jpiglo
4607	ijt = jpiglo-ji+2
4608	DO jk = 1,klimit,1
4609	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4610	ztab(ji,jjr, jk) = psgn * ztab(ijt,jjr-2,jk)
4611	END DO
4612	END DO
4613	#else
4614	DO jk = 1,klimit,1
4615	DO ji = 2, jpiglo/2
4616	ijt = jpiglo-ji+2
4617	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4618	END DO
4619	DO ji = jpiglo/2+1, jpiglo
4620	ijt = jpiglo-ji+2
4621	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4622	ztab(ji,jjr, jk) = psgn * ztab(ijt,jjr-2,jk)
4623	END DO
4624	END DO
4625	#endif
4626	ELSE
4627	#if defined key_z_first
4628	DO ji = 2, jpiglo
4629	ijt = jpiglo-ji+2
4630	DO jk=1,klimit,1
4631	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4632	END DO
4633	END DO
4634	DO ji = jpiglo/2+1, jpiglo
4635	ijt = jpiglo-ji+2
4636	DO jk=1,klimit,1
4637	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4638	END DO
4639	END DO
4640	#else
4641	DO jk=1,klimit,1
4642	DO ji = 2, jpiglo
4643	ijt = jpiglo-ji+2
4644	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4645	END DO
4646	DO ji = jpiglo/2+1, jpiglo
4647	ijt = jpiglo-ji+2
4648	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4649	END DO
4650	END DO
4651	#endif
4652	END IF
4653
4654	CASE ( 'U' ) ! U-point
4655
4656	IF(field_is_real)THEN
4657	#if defined key_z_first
4658	DO ji = 1, jpiglo-1
4659	iju = jpiglo-ji+1
4660	DO jk=1,klimit,1
4661	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk)
4662	END DO
4663	END DO
4664	DO ji = jpiglo/2, jpiglo-1
4665	iju = jpiglo-ji+1
4666	DO jk=1,klimit,1
4667	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4668	END DO
4669	END DO
4670	#else
4671	DO jk=1,klimit,1
4672	DO ji = 1, jpiglo-1
4673	iju = jpiglo-ji+1
4674	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-2,jk)
4675	END DO
4676	DO ji = jpiglo/2, jpiglo-1
4677	iju = jpiglo-ji+1
4678	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4679	END DO
4680	END DO
4681	#endif
4682	ELSE
4683	#if defined key_z_first
4684	DO ji = 1, jpiglo-1
4685	iju = jpiglo-ji+1
4686	DO jk=1,klimit,1
4687	iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk)
4688	END DO
4689	END DO
4690	DO ji = jpiglo/2, jpiglo-1
4691	iju = jpiglo-ji+1
4692	DO jk=1,klimit,1
4693	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
4694	END DO
4695	END DO
4696	#else
4697	DO jk=1,klimit,1
4698	DO ji = 1, jpiglo-1
4699	iju = jpiglo-ji+1
4700	iztab(ji,jji,jk) = isgn * iztab(iju,jji-2,jk)
4701	END DO
4702	DO ji = jpiglo/2, jpiglo-1
4703	iju = jpiglo-ji+1
4704	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
4705	END DO
4706	END DO
4707	#endif
4708	END IF
4709
4710	CASE ( 'V' ) ! V-point
4711
4712	IF(field_is_real)THEN
4713	#if defined key_z_first
4714	DO ji = 2, jpiglo
4715	ijt = jpiglo-ji+2
4716	DO jk=1,klimit,1
4717	#else
4718	DO jk=1,klimit,1
4719	DO ji = 2, jpiglo
4720	ijt = jpiglo-ji+2
4721	#endif
4722	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-2,jk)
4723	ztab(ji,jjr ,jk) = psgn * ztab(ijt,jjr-3,jk)
4724	END DO
4725	END DO
4726	ELSE
4727	#if defined key_z_first
4728	DO ji = 2, jpiglo
4729	ijt = jpiglo-ji+2
4730	DO jk=1,klimit,1
4731	#else
4732	DO jk=1,klimit,1
4733	DO ji = 2, jpiglo
4734	ijt = jpiglo-ji+2
4735	#endif
4736	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-2,jk)
4737	iztab(ji,jji ,jk) = isgn * iztab(ijt,jji-3,jk)
4738	END DO
4739	END DO
4740	END IF
4741
4742	CASE ( 'F' , 'G' ) ! F-point
4743
4744	IF(field_is_real)THEN
4745	#if defined key_z_first
4746	DO ji = 1, jpiglo-1
4747	iju = jpiglo-ji+1
4748	DO jk=1,klimit,1
4749	#else
4750	DO jk=1,klimit,1
4751	DO ji = 1, jpiglo-1
4752	iju = jpiglo-ji+1
4753	#endif
4754	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-2,jk)
4755	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-3,jk)
4756	END DO
4757	END DO
4758	ELSE
4759	#if defined key_z_first
4760	DO ji = 1, jpiglo-1
4761	iju = jpiglo-ji+1
4762	DO jk=1,klimit,1
4763	#else
4764	DO jk=1,klimit,1
4765	DO ji = 1, jpiglo-1
4766	iju = jpiglo-ji+1
4767	#endif
4768	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-2,jk)
4769	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-3,jk)
4770	END DO
4771	END DO
4772	END IF
4773
4774	CASE ( 'I' ) ! ice U-V point
4775
4776	IF(field_is_real)THEN
4777	#if defined key_z_first
4778	DO jk=1,klimit,1
4779	ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk)
4780	END DO
4781	DO ji = 3, jpiglo
4782	iju = jpiglo - ji + 3
4783	DO jk=1,klimit,1
4784	#else
4785	DO jk=1,klimit,1
4786	ztab(2,jjr,jk) = psgn * ztab(3,jjr-1,jk)
4787	DO ji = 3, jpiglo
4788	iju = jpiglo - ji + 3
4789	#endif
4790	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk)
4791	END DO
4792	END DO
4793	ELSE
4794	#if defined key_z_first
4795	DO jk=1,klimit,1
4796	iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk)
4797	END DO
4798	DO ji = 3, jpiglo
4799	iju = jpiglo - ji + 3
4800	DO jk=1,klimit,1
4801	#else
4802	DO jk=1,klimit,1
4803	iztab(2,jji,jk) = isgn * iztab(3,jji-1,jk)
4804	DO ji = 3, jpiglo
4805	iju = jpiglo - ji + 3
4806	#endif
4807	iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk)
4808	END DO
4809	END DO
4810	END IF
4811
4812	END SELECT
4813
4814	! Move to the next set of ijpj rows corresponding to the next field
4815	jjr = jjr + ijpj
4816	jji = jji + ijpj
4817
4818	END DO ! Loop over fields
4819
4820	CASE ( 5, 6 ) ! * North fold F-point pivot
4821
4822	DO ifield=1, nfields, 1
4823
4824	! Set-up stuff dependent on whether this field is real or integer
4825	field_is_real = .FALSE.
4826	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4827	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
4828
4829	isgn = list(ifield)%isgn
4830	psgn=REAL(isgn, wp)
4831
4832	! Set up stuff dependent on whether this field is 2- or 3-dimensional
4833	IF(fields_all_3d)THEN
4834	klimit=jpk
4835	ELSE IF(fields_all_2d)THEN
4836	klimit = 1
4837	ELSE
4838	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
4839	ASSOCIATED(list(ifield)%i3dptr) )THEN
4840	klimit=jpk
4841	ELSE
4842	klimit = 1
4843	END IF
4844	END IF
4845
4846	IF(field_is_real)THEN
4847	DO jk = 1, klimit, 1
4848	ztab( 1 ,jjr,jk) = 0.0_wp
4849	ztab(jpiglo,jjr,jk) = 0.0_wp
4850	END DO
4851	ELSE
4852	DO jk = 1, klimit, 1
4853	iztab( 1 ,jji,jk) = 0
4854	iztab(jpiglo,jji,jk) = 0
4855	END DO
4856	END IF
4857
4858	SELECT CASE ( list(ifield)%grid )
4859
4860	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
4861
4862	IF(field_is_real)THEN
4863	#if defined key_z_first
4864	DO ji = 1, jpiglo
4865	ijt = jpiglo-ji+1
4866	DO jk = 1,klimit,1
4867	#else
4868	DO jk = 1,klimit,1
4869	DO ji = 1, jpiglo
4870	ijt = jpiglo-ji+1
4871	#endif
4872	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-1,jk)
4873	END DO
4874	END DO
4875	ELSE
4876	#if defined key_z_first
4877	DO ji = 1, jpiglo
4878	ijt = jpiglo-ji+1
4879	DO jk=1,klimit,1
4880	#else
4881	DO jk=1,klimit,1
4882	DO ji = 1, jpiglo
4883	ijt = jpiglo-ji+1
4884	#endif
4885	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-1,jk)
4886	END DO
4887	END DO
4888	END IF
4889
4890	CASE ( 'U' ) ! U-point
4891
4892	IF(field_is_real)THEN
4893	#if defined key_z_first
4894	DO ji = 1, jpiglo-1
4895	iju = jpiglo-ji
4896	DO jk=1,klimit,1
4897	#else
4898	DO jk=1,klimit,1
4899	DO ji = 1, jpiglo-1
4900	iju = jpiglo-ji
4901	#endif
4902	ztab(ji,jjr,jk) = psgn * ztab(iju,jjr-1,jk)
4903	END DO
4904	END DO
4905	ELSE
4906	#if defined key_z_first
4907	DO ji = 1, jpiglo-1
4908	iju = jpiglo-ji
4909	DO jk=1,klimit,1
4910	#else
4911	DO jk=1,klimit,1
4912	DO ji = 1, jpiglo-1
4913	iju = jpiglo-ji
4914	#endif
4915	iztab(ji,jji,jk) = isgn * iztab(iju,jji-1,jk)
4916	END DO
4917	END DO
4918	END IF
4919
4920	CASE ( 'V' ) ! V-point
4921	IF(field_is_real)THEN
4922	#if defined key_z_first
4923	DO ji = 1, jpiglo
4924	ijt = jpiglo-ji+1
4925	DO jk=1,klimit,1
4926	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4927	END DO
4928	END DO
4929	DO ji = jpiglo/2+1, jpiglo
4930	ijt = jpiglo-ji+1
4931	DO jk=1,klimit,1
4932	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4933	END DO
4934	END DO
4935	#else
4936	DO jk=1,klimit,1
4937	DO ji = 1, jpiglo
4938	ijt = jpiglo-ji+1
4939	ztab(ji,jjr,jk) = psgn * ztab(ijt,jjr-2,jk)
4940	END DO
4941	DO ji = jpiglo/2+1, jpiglo
4942	ijt = jpiglo-ji+1
4943	ztab(ji,jjr-1,jk) = psgn * ztab(ijt,jjr-1,jk)
4944	END DO
4945	END DO
4946	#endif
4947	ELSE
4948	#if defined key_z_first
4949	DO ji = 1, jpiglo
4950	ijt = jpiglo-ji+1
4951	DO jk=1,klimit,1
4952	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4953	END DO
4954	END DO
4955	DO ji = jpiglo/2+1, jpiglo
4956	ijt = jpiglo-ji+1
4957	DO jk=1,klimit,1
4958	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4959	END DO
4960	END DO
4961	#else
4962	DO jk=1,klimit,1
4963	DO ji = 1, jpiglo
4964	ijt = jpiglo-ji+1
4965	iztab(ji,jji,jk) = isgn * iztab(ijt,jji-2,jk)
4966	END DO
4967	DO ji = jpiglo/2+1, jpiglo
4968	ijt = jpiglo-ji+1
4969	iztab(ji,jji-1,jk) = isgn * iztab(ijt,jji-1,jk)
4970	END DO
4971	END DO
4972	#endif
4973	END IF
4974
4975	CASE ( 'F' , 'G' ) ! F-point
4976
4977	IF(field_is_real)THEN
4978	#if defined key_z_first
4979
4980	DO ji = 1, jpiglo-1
4981	iju = jpiglo-ji
4982	DO jk=1,klimit,1
4983	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-2,jk)
4984	END DO
4985	END DO
4986	DO ji = jpiglo/2+1, jpiglo-1
4987	iju = jpiglo-ji
4988	DO jk=1,klimit,1
4989	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
4990	END DO
4991	END DO
4992	#else
4993	DO jk=1,klimit,1
4994	DO ji = 1, jpiglo-1
4995	iju = jpiglo-ji
4996	ztab(ji,jjr ,jk) = psgn * ztab(iju,jjr-2,jk)
4997	END DO
4998	DO ji = jpiglo/2+1, jpiglo-1
4999	iju = jpiglo-ji
5000	ztab(ji,jjr-1,jk) = psgn * ztab(iju,jjr-1,jk)
5001	END DO
5002	END DO
5003	#endif
5004	ELSE
5005	#if defined key_z_first
5006	DO ji = 1, jpiglo-1
5007	iju = jpiglo-ji
5008	DO jk=1,klimit,1
5009	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-2,jk)
5010	END DO
5011	END DO
5012	DO ji = jpiglo/2+1, jpiglo-1
5013	iju = jpiglo-ji
5014	DO jk=1,klimit,1
5015	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
5016	END DO
5017	END DO
5018	#else
5019	DO jk=1,klimit,1
5020	DO ji = 1, jpiglo-1
5021	iju = jpiglo-ji
5022	iztab(ji,jji ,jk) = isgn * iztab(iju,jji-2,jk)
5023	END DO
5024	DO ji = jpiglo/2+1, jpiglo-1
5025	iju = jpiglo-ji
5026	iztab(ji,jji-1,jk) = isgn * iztab(iju,jji-1,jk)
5027	END DO
5028	END DO
5029	#endif
5030	END IF
5031
5032	CASE ( 'I' ) ! ice U-V point
5033
5034	IF(field_is_real)THEN
5035	#if defined key_z_first
5036	DO jk=1,klimit,1
5037	ztab( 2 ,jjr,jk) = 0._wp
5038	END DO
5039	DO ji = 2 , jpiglo-1
5040	ijt = jpiglo - ji + 2
5041	DO jk=1,klimit,1
5042	ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + &
5043	psgn * ztab(ijt,jjr-1,jk) )
5044	END DO
5045	END DO
5046	#else
5047	DO jk=1,klimit,1
5048	ztab( 2 ,jjr,jk) = 0._wp
5049	DO ji = 2 , jpiglo-1
5050	ijt = jpiglo - ji + 2
5051	ztab(ji,jjr,jk)= 0.5 * ( ztab(ji,jjr-1,jk) + &
5052	psgn * ztab(ijt,jjr-1,jk) )
5053	END DO
5054	END DO
5055	#endif
5056	ELSE
5057	#if defined key_z_first
5058	DO jk=1,klimit,1
5059	iztab( 2 ,jji,jk) = 0
5060	END DO
5061	DO ji = 2 , jpiglo-1
5062	ijt = jpiglo - ji + 2
5063	DO jk=1,klimit,1
5064	iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + &
5065	isgn * iztab(ijt,jji-1,jk) )
5066	END DO
5067	END DO
5068	#else
5069	DO jk=1,klimit,1
5070	iztab( 2 ,jji,jk) = 0
5071	DO ji = 2 , jpiglo-1
5072	ijt = jpiglo - ji + 2
5073	iztab(ji,jji,jk)= 0.5 * ( iztab(ji,jji-1,jk) + &
5074	isgn * iztab(ijt,jji-1,jk) )
5075	END DO
5076	END DO
5077	#endif
5078	END IF
5079
5080	END SELECT
5081
5082	! Move to the next set of ijpj rows corresponding to the next field
5083	jjr = jjr + ijpj
5084	jji = jji + ijpj
5085	END DO ! loop over fields
5086
5087	CASE DEFAULT ! * closed : the code probably never go through
5088
5089	DO ifield=1, nfields, 1
5090
5091	! Set-up stuff dependent on whether this field is real or integer
5092	field_is_real = .FALSE.
5093	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
5094	ASSOCIATED(list(ifield)%r2dptr) )field_is_real = .TRUE.
5095
5096	! Set up stuff dependent on whether this field is
5097	! 2- or 3-dimensional
5098	IF(fields_all_3d)THEN
5099	klimit=jpk
5100	ELSE IF(fields_all_2d)THEN
5101	klimit = 1
5102	ELSE
5103	IF(ASSOCIATED(list(ifield)%r3dptr) .OR. &
5104	ASSOCIATED(list(ifield)%i3dptr) )THEN
5105	klimit=jpk
5106	ELSE
5107	klimit = 1
5108	END IF
5109	END IF
5110
5111	SELECT CASE ( list(ifield)%grid)
5112
5113	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5114	IF(field_is_real)THEN
5115	#if defined key_z_first
5116	DO ii = 1, jpiglo, 1
5117	DO jk = 1, klimit, 1
5118	#else
5119	DO jk = 1, klimit, 1
5120	DO ii = 1, jpiglo, 1
5121	#endif
5122	ztab(ii, 1 , jk) = 0_wp
5123	ztab(ii,jjr, jk) = 0_wp
5124	END DO
5125	END DO
5126	ELSE
5127	#if defined key_z_first
5128	DO ii = 1, jpiglo, 1
5129	DO jk = 1, klimit, 1
5130	#else
5131	DO jk = 1, klimit, 1
5132	DO ii = 1, jpiglo, 1
5133	#endif
5134	iztab(ii, 1 ,jk) = 0
5135	iztab(ii,jji,jk) = 0
5136	END DO
5137	END DO
5138	END IF
5139
5140	CASE ( 'F' ) ! F-point
5141	IF(field_is_real)THEN
5142	ztab(:,jjr,1:klimit) = 0_wp
5143	ELSE
5144	iztab(:,jji,1:klimit) = 0
5145	END IF
5146
5147	CASE ( 'I' ) ! ice U-V point
5148	IF(field_is_real)THEN
5149	#if defined key_z_first
5150	DO ii = 1, jpiglo, 1
5151	DO jk = 1, klimit, 1
5152	#else
5153	DO jk = 1, klimit, 1
5154	DO ii = 1, jpiglo, 1
5155	#endif
5156	ztab(ii, 1 ,jk) = 0_wp
5157	ztab(ii,jjr,jk) = 0_wp
5158	END DO
5159	END DO
5160	ELSE
5161	#if defined key_z_first
5162	DO ii = 1, jpiglo, 1
5163	DO jk = 1, klimit, 1
5164	#else
5165	DO jk = 1, klimit, 1
5166	DO ii = 1, jpiglo, 1
5167	#endif
5168	iztab(ii, 1 ,jk) = 0
5169	iztab(ii,jji,jk) = 0
5170	END DO
5171	END DO
5172	END IF
5173
5174	END SELECT
5175
5176	! Move to the next set of ijpj rows corresponding to the next field
5177	jjr = jjr + ijpj
5178	jji = jji + ijpj
5179	END DO ! loop over fields
5180
5181	END SELECT
5182
5183
5184	! End of slab
5185	! ===========
5186
5187	!! Scatter back to original array(s)
5188	!!$ DO jr = 1, ndim_rank_north
5189	!!$ jproc=nrank_north(jr)+1
5190	!!$ ildi=nldit (jproc)
5191	!!$ ilei=nleit (jproc)
5192	!!$ iilb=pielb(jproc)
5193	!!$ IF(.NOT. fields_all_int)THEN
5194	!!$ znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5195	!!$ ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5196	!!$ END IF
5197	!!$ IF(.NOT. fields_all_real)THEN
5198	!!$ iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5199	!!$ iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5200	!!$ END IF
5201	!!$ END DO
5202
5203	IF(fields_all_int)THEN
5204
5205	DO jr = 1, ndim_rank_north
5206	jproc=nrank_north(jr)+1
5207	ildi=nldit (jproc)
5208	ilei=nleit (jproc)
5209	iilb=pielb(jproc)
5210	! ARPDBG - make loop ordering explicit for performance?
5211	iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5212	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5213	END DO
5214
5215	ELSE IF(fields_all_real)THEN
5216
5217	DO jr = 1, ndim_rank_north
5218	jproc=nrank_north(jr)+1
5219	ildi=nldit (jproc)
5220	ilei=nleit (jproc)
5221	iilb=pielb(jproc)
5222	! ARPDBG - make loop ordering explicit for performance?
5223	znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5224	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5225	END DO
5226
5227	ELSE ! Have some real and some integer fields
5228
5229	DO jr = 1, ndim_rank_north
5230	jproc=nrank_north(jr)+1
5231	ildi=nldit (jproc)
5232	ilei=nleit (jproc)
5233	iilb=pielb(jproc)
5234	! ARPDBG - make loop ordering explicit for performance?
5235	znorthgloio(ildi:ilei,1:ishiftr,1:klimit,jr) = &
5236	ztab(iilb:iilb+piesub(jproc)-1,1:ishiftr,1:klimit)
5237	iznorthgloio(ildi:ilei,1:ishifti,1:klimit,jr) = &
5238	iztab(iilb:iilb+piesub(jproc)-1,1:ishifti,1:klimit)
5239	END DO
5240
5241	END IF
5242
5243	ENDIF ! only done on proc 0 of ncomm_north
5244
5245	CALL prof_region_end(ARPNORTHAPPLYSYMM, iprofStat)
5246
5247	CALL prof_region_begin(NORTHLISTSCATTER, "NorthListScatter", iprofStat)
5248
5249	IF ( npolj /= 0 ) THEN
5250	IF(.NOT. fields_all_int)THEN
5251	itaille=nwidthmaxishiftrklimit
5252	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
5253	znorthloc, itaille,MPI_DOUBLE_PRECISION, &
5254	0, ncomm_north,ierr)
5255	END IF
5256	IF(.NOT. fields_all_real)THEN
5257	itaille=nwidthmaxishiftiklimit
5258	CALL MPI_SCATTER(iznorthgloio,itaille,MPI_INTEGER, &
5259	iznorthloc, itaille,MPI_INTEGER, &
5260	0, ncomm_north,ierr)
5261
5262	END IF
5263	ENDIF
5264
5265	! put back the last ijpj jlines of each field
5266	ishiftr = 0
5267	ishifti = 0
5268	DO ifield=1,nfields,1
5269
5270	IF(ASSOCIATED(list(ifield)%r2dptr))THEN
5271	DO ij = 1, ijpj, 1
5272	jj = nlcj - ijpj + ij
5273	list(ifield)%r2dptr(nldi:nlei,jj)= znorthloc(nldi:nlei,ij+ishiftr,1)
5274	END DO
5275	ishiftr = ishiftr + ijpj
5276	ELSE IF(ASSOCIATED(list(ifield)%r3dptr))THEN
5277	#if defined key_z_first
5278	DO ij = 1, ijpj, 1
5279	jj = nlcj - ijpj + ij
5280	DO jk = 1, jpk
5281	#else
5282	DO jk = 1, jpk
5283	DO ij = 1, ijpj, 1
5284	jj = nlcj - ijpj + ij
5285	#endif
5286	! ARPDBG Make loop over i explicit for performance?
5287	list(ifield)%r3dptr(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij+ishiftr,jk)
5288	END DO
5289	END DO
5290	ishiftr = ishiftr + ijpj
5291	ELSE IF(ASSOCIATED(list(ifield)%i2dptr))THEN
5292	DO ij = 1, ijpj, 1
5293	jj = nlcj - ijpj + ij
5294	list(ifield)%i2dptr(nldi:nlei,jj)= iznorthloc(nldi:nlei,ij+ishifti,1)
5295	END DO
5296	ishifti = ishifti + ijpj
5297	ELSE IF(ASSOCIATED(list(ifield)%i3dptr))THEN
5298	#if defined key_z_first
5299	DO ij = 1, ijpj, 1
5300	jj = nlcj - ijpj + ij
5301	DO jk = 1, jpk
5302	#else
5303	DO jk = 1, jpk
5304	DO ij = 1, ijpj, 1
5305	jj = nlcj - ijpj + ij
5306	#endif
5307	! ARPDBG Make loop over i explicit for performance?
5308	list(ifield)%i3dptr(nldi:nlei,jj,jk)= iznorthloc(nldi:nlei,ij+ishifti,jk)
5309	END DO
5310	END DO
5311	ishifti = ishifti + ijpj
5312	END IF
5313	END DO ! loop over fields
5314
5315	CALL prof_region_end(NORTHLISTSCATTER, iprofStat)
5316
5317	#endif /* key_mpp_mpi */
5318
5319	CALL prof_region_end(ARPNORTHLISTCOMMS, iprofStat)
5320
5321	END SUBROUTINE mpp_lbc_north_list
5322
5323	!============================================================================
5324
5325	SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn)
5326	!!---------------------------------------------------------------------
5327	!! * routine mpp_lbc_north_2d *
5328	!!
5329	!! ** Purpose :
5330	!! Ensure proper north fold horizontal bondary condition in mpp
5331	!! configuration in case of jpn1 > 1 (for 2d array )
5332	!!
5333	!! ** Method :
5334	!! Gather the 4 northern lines of the global domain on 1 processor and
5335	!! apply lbc north-fold on this sub array. Then scatter the fold array
5336	!! back to the processors.
5337	!!
5338	!! History :
5339	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5340	!! from lbc routine
5341	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding
5342	!! rules of lbc_lnk
5343	!!----------------------------------------------------------------------
5344	USE par_oce, ONLY : jpni, jpi, jpj
5345	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, nlcj, &
5346	nwidthmax
5347	USE mapcomm_mod, ONLY : pielb, piesub
5348	USE lib_mpp, ONLY : ctl_stop
5349	USE arpdebugging, ONLY: dump_array
5350	IMPLICIT none
5351	!! * Arguments
5352	CHARACTER(len=1), INTENT( in ) :: &
5353	cd_type ! nature of pt2d grid-points
5354	! ! = T , U , V , F or W gridpoints
5355	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
5356	pt2d ! 2D array on which the boundary condition is applied
5357	REAL(wp), INTENT( in ) :: &
5358	psgn ! control of the sign change
5359	! ! = -1. , the sign is changed if north fold boundary
5360	! ! = 1. , the sign is kept if north fold boundary
5361
5362	!! * Local declarations
5363
5364	INTEGER :: ijpj
5365	INTEGER :: ji, jj, jr, jproc
5366	INTEGER :: ierr
5367	INTEGER :: ildi,ilei,iilb
5368	INTEGER :: ijpjm1,ij,ijt,iju
5369	INTEGER :: itaille
5370
5371	REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: ztab2
5372	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio2
5373	REAL(wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: znorthloc2
5374	!!----------------------------------------------------------------------
5375	!! OPA 8.5, LODYC-IPSL (2002)
5376	!!----------------------------------------------------------------------
5377	! If we get in this routine it's because : North fold condition and mpp
5378	! with more than one PE across i : we deal only with the North condition
5379
5380	! Set local from public PARAMETER
5381	ijpj = num_nfold_rows
5382
5383	CALL prof_region_begin(ARPNORTHCOMMS2D, "North2D", iprofStat)
5384
5385	#if defined key_mpp_mpi
5386
5387	IF(.not. ALLOCATED(ztab2))THEN
5388
5389	ALLOCATE(ztab2(jpiglo,ijpj), &
5390	znorthgloio2(nwidthmax,ijpj,ndim_rank_north), &
5391	znorthloc2(nwidthmax,ijpj), &
5392	STAT=ierr)
5393	IF(ierr .ne. 0)THEN
5394	CALL ctl_stop('STOP','mpp_lbc_north_2d: memory allocation failed' )
5395	END IF
5396	END IF
5397
5398	! 0. Sign setting
5399	! ---------------
5400
5401	ijpjm1=ijpj-1
5402
5403	! put the last ijpj jlines of pt2d into znorthloc2
5404	znorthloc2(:,:) = 0_wp ! because of padding for nwidthmax
5405
5406	! jeub is the upper j limit of current domain in global coords
5407	!
5408	! \|======================= jpjglo ^
5409	! <Trimmed> \| /\|\
5410	! \|----------------------- jpjglo-1 \|
5411	! \| \|
5412	! \|---------jeub--------------------------------
5413	! \| \| j
5414	! \|--------------------------------------------
5415	! \| \| \|
5416	! \|-------------------------------------------- \|
5417	!
5418	! No. of trimmed rows = jpjglo - jeub
5419	! No. of valid rows for n-fold = ijpj - <no. trimmed rows>
5420	! = ijpj - jpjglo + jeub
5421	! Need an iterator that ends with max value ijpj and has (ijpj-jpjglo+jeub)
5422	! distinct values so start point must be:
5423	! ij_start = ijpj - (ijpj-jpjglo+jeub) + 1 = jpjglo - jeub + 1
5424	! => if jeub == jpjglo then we recover a starting value of 1.
5425	! if jeub == jpjglo - 10 then ij_start = 11 so no loop iterations
5426	! will be performed.
5427
5428	#if defined NO_NFOLD_GATHER
5429	! Post receives for other PE's north-fold data
5430	DO iproc = 1, ndim_rank_north, 1
5431
5432	IF( iproc-1 == nrank_north(iproc) ) CYCLE ! Skip this PE
5433
5434	CALL MPI_IRecv(znorthgloio2(), north_pts(iproc), MPI_DOUBLE_PRECISION, &
5435	nrank_north(iproc), iproc, tag, ncomm_north, &
5436	nexch_flag(iproc) )
5437	END DO
5438	#endif
5439
5440	DO ij = jpjglo - jeub + 1, ijpj, 1
5441
5442	jj = nlcj - ijpj + ij
5443	znorthloc2(nldi:nlei,ij)=pt2d(nldi:nlei,jj)
5444	END DO
5445
5446	! CALL dump_array(0,'znorthloc2',znorthloc2,withHalos=.TRUE.,toGlobal=.FALSE.)
5447
5448	IF (npolj /= 0 ) THEN
5449	! Build in proc 0 of ncomm_north the znorthgloio2
5450	znorthgloio2(:,:,:) = 0_wp
5451	itaille=nwidthmax*ijpj
5452	CALL MPI_GATHER(znorthloc2,itaille,MPI_DOUBLE_PRECISION, &
5453	znorthgloio2,itaille,MPI_DOUBLE_PRECISION, &
5454	0, ncomm_north, ierr)
5455
5456	ENDIF
5457
5458	IF (narea == north_root+1 ) THEN
5459	! recover the global north array
5460	! ztab2 has full width of global domain
5461	ztab2(:,:) = 0_wp
5462
5463	DO jr = 1, ndim_rank_north
5464	jproc=nrank_north(jr)+1
5465	ildi=nldit(jproc)
5466	ilei=nleit(jproc)
5467	iilb=pielb(jproc)
5468	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)= &
5469	znorthgloio2(ildi:ilei,1:ijpj,jr)
5470	END DO
5471
5472	! CALL dump_array(0,'ztab2',ztab2,withHalos=.TRUE.,toGlobal=.FALSE.)
5473
5474	! 2. North-Fold boundary conditions
5475	! ----------------------------------
5476
5477	SELECT CASE ( npolj )
5478
5479	CASE ( 3, 4 ) ! * North fold T-point pivot
5480
5481	ztab2( 1 ,ijpj) = 0._wp
5482	ztab2(jpiglo,ijpj) = 0._wp
5483
5484	SELECT CASE ( cd_type )
5485
5486	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
5487	DO ji = 2, jpiglo
5488	ijt = jpiglo-ji+2
5489	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2)
5490	END DO
5491	DO ji = jpiglo/2+1, jpiglo
5492	ijt = jpiglo-ji+2
5493	ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1)
5494	END DO
5495
5496	CASE ( 'U' ) ! U-point
5497	DO ji = 1, jpiglo-1
5498	iju = jpiglo-ji+1
5499	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-2)
5500	END DO
5501	DO ji = jpiglo/2, jpiglo-1
5502	iju = jpiglo-ji+1
5503	ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1)
5504	END DO
5505
5506	CASE ( 'V' ) ! V-point
5507	DO ji = 2, jpiglo
5508	ijt = jpiglo-ji+2
5509	ztab2(ji,ijpj-1) = psgn * ztab2(ijt,ijpj-2)
5510	ztab2(ji,ijpj ) = psgn * ztab2(ijt,ijpj-3)
5511	END DO
5512
5513	CASE ( 'F' , 'G' ) ! F-point
5514	DO ji = 1, jpiglo-1
5515	iju = jpiglo-ji+1
5516	ztab2(ji,ijpj-1) = psgn * ztab2(iju,ijpj-2)
5517	ztab2(ji,ijpj ) = psgn * ztab2(iju,ijpj-3)
5518	END DO
5519
5520	CASE ( 'I' ) ! ice U-V point
5521	ztab2(2,ijpj) = psgn * ztab2(3,ijpj-1)
5522	DO ji = 3, jpiglo
5523	iju = jpiglo - ji + 3
5524	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1)
5525	END DO
5526
5527	END SELECT
5528
5529	CASE ( 5, 6 ) ! * North fold F-point pivot
5530
5531	ztab2( 1 ,ijpj) = 0._wp
5532	ztab2(jpiglo,ijpj) = 0._wp
5533
5534	SELECT CASE ( cd_type )
5535
5536	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
5537	DO ji = 1, jpiglo
5538	ijt = jpiglo-ji+1
5539	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-1)
5540	END DO
5541
5542	CASE ( 'U' ) ! U-point
5543	DO ji = 1, jpiglo-1
5544	iju = jpiglo-ji
5545	ztab2(ji,ijpj) = psgn * ztab2(iju,ijpj-1)
5546	END DO
5547
5548	CASE ( 'V' ) ! V-point
5549	DO ji = 1, jpiglo
5550	ijt = jpiglo-ji+1
5551	ztab2(ji,ijpj) = psgn * ztab2(ijt,ijpj-2)
5552	END DO
5553	DO ji = jpiglo/2+1, jpiglo
5554	ijt = jpiglo-ji+1
5555	ztab2(ji,ijpjm1) = psgn * ztab2(ijt,ijpjm1)
5556	END DO
5557
5558	CASE ( 'F' , 'G' ) ! F-point
5559	DO ji = 1, jpiglo-1
5560	iju = jpiglo-ji
5561	ztab2(ji,ijpj ) = psgn * ztab2(iju,ijpj-2)
5562	END DO
5563	DO ji = jpiglo/2+1, jpiglo-1
5564	iju = jpiglo-ji
5565	ztab2(ji,ijpjm1) = psgn * ztab2(iju,ijpjm1)
5566	END DO
5567
5568	CASE ( 'I' ) ! ice U-V point
5569	ztab2( 2 ,ijpj) = 0.e0
5570	DO ji = 2 , jpiglo-1
5571	ijt = jpiglo - ji + 2
5572	ztab2(ji,ijpj)= 0.5 * ( ztab2(ji,ijpj-1) + psgn * ztab2(ijt,ijpj-1) )
5573	END DO
5574
5575	END SELECT
5576
5577	CASE DEFAULT ! * closed : the code probably never go through
5578
5579	SELECT CASE ( cd_type)
5580
5581	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5582	ztab2(:, 1 ) = 0._wp
5583	ztab2(:,ijpj) = 0._wp
5584
5585	CASE ( 'F' ) ! F-point
5586	ztab2(:,ijpj) = 0._wp
5587
5588	CASE ( 'I' ) ! ice U-V point
5589	ztab2(:, 1 ) = 0._wp
5590	ztab2(:,ijpj) = 0._wp
5591
5592	END SELECT
5593
5594	END SELECT
5595
5596	! End of slab
5597	! ===========
5598
5599	!! Scatter back to pt2d
5600	DO jr = 1, ndim_rank_north
5601	jproc=nrank_north(jr)+1
5602	ildi=nldit (jproc)
5603	ilei=nleit (jproc)
5604	iilb=pielb(jproc)
5605	znorthgloio2(ildi:ilei,1:ijpj,jr)= &
5606	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
5607	END DO
5608
5609	ENDIF ! only done on proc 0 of ncomm_north
5610
5611	IF ( npolj /= 0 ) THEN
5612	itaille=nwidthmax*ijpj
5613	CALL MPI_SCATTER(znorthgloio2,itaille,MPI_DOUBLE_PRECISION, &
5614	znorthloc2, itaille,MPI_DOUBLE_PRECISION, &
5615	0,ncomm_north,ierr)
5616	ENDIF
5617
5618	! Put the last ijpj jlines of pt2d into znorthloc2 while allowing
5619	! for any trimming of domain (see earlier comments and diagram)
5620	DO ij = jpjglo - jeub + 1, ijpj, 1
5621	jj = nlcj - ijpj + ij
5622	pt2d(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
5623	END DO
5624
5625	#endif /* key_mpp_mpi */
5626
5627	CALL prof_region_end(ARPNORTHCOMMS2D, iprofStat)
5628
5629	END SUBROUTINE mpp_lbc_north_2d
5630
5631	!====================================================================
5632
5633	SUBROUTINE mpp_lbc_north_i2d ( ib2, cd_type, isgn)
5634	!!---------------------------------------------------------------------
5635	!! * routine mpp_lbc_north_2d *
5636	!!
5637	!! ** Purpose :
5638	!! Ensure proper north fold horizontal bondary condition in mpp
5639	!! configuration in case of jpn1 > 1 (for 2d array )
5640	!!
5641	!! ** Method :
5642	!! Gather the 4 northern lines of the global domain on 1 processor and
5643	!! apply lbc north-fold on this sub array. Then scatter the fold array
5644	!! back to the processors.
5645	!!
5646	!! History :
5647	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5648	!! from lbc routine
5649	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp,
5650	!! coding rules of lbc_lnk
5651	!!----------------------------------------------------------------------
5652	USE par_oce, ONLY : jpni, jpi, jpj
5653	USE dom_oce, ONLY : nldi, nlei, npolj, nldit, nleit, narea, &
5654	nlcj, nwidthmax
5655	USE mapcomm_mod, ONLY : pielb, piesub
5656	USE lib_mpp, ONLY : ctl_stop
5657	IMPLICIT none
5658	!! * Arguments
5659	CHARACTER(len=1), INTENT( in ) :: &
5660	cd_type ! nature of ib2 grid-points
5661	! ! = T , U , V , F or W gridpoints
5662	INTEGER, DIMENSION(jpi,jpj), INTENT( inout ) :: &
5663	ib2 ! 2D array on which the boundary condition is applied
5664	INTEGER, INTENT( in ) :: &
5665	isgn ! control of the sign change
5666	! ! = -1. , the sign is changed if north fold boundary
5667	! ! = 1. , the sign is kept if north fold boundary
5668
5669	!! * Local declarations
5670
5671	INTEGER :: ijpj
5672	INTEGER :: ji, jj, jr, jproc
5673	INTEGER :: ierr
5674	INTEGER :: ildi,ilei,iilb
5675	INTEGER :: ijpjm1,ij,ijt,iju
5676	INTEGER :: itaille
5677
5678	INTEGER, DIMENSION(:,:), ALLOCATABLE :: ztab2
5679	INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio2
5680	INTEGER, DIMENSION(:,:), ALLOCATABLE :: znorthloc2
5681	!!----------------------------------------------------------------------
5682	!! OPA 8.5, LODYC-IPSL (2002)
5683	!!----------------------------------------------------------------------
5684	! If we get in this routine it's because : North fold condition and mpp
5685	! with more than one PE across i : we deal only with the North condition
5686
5687	#if defined key_mpp_mpi
5688
5689	ijpj = num_nfold_rows
5690	ijpjm1=ijpj - 1
5691
5692
5693	IF(.not. ALLOCATED(ztab2))THEN
5694
5695	ALLOCATE(ztab2(jpiglo,ijpj), &
5696	znorthgloio2(nwidthmax,ijpj,jpni), &
5697	znorthloc2(nwidthmax,ijpj), &
5698	STAT=ierr)
5699	IF(ierr .ne. 0)THEN
5700	CALL ctl_stop('STOP','mpp_lbc_north_i2d: memory allocation failed')
5701	END IF
5702	END IF
5703
5704	! 0. Sign setting
5705	! ---------------
5706
5707	! Put the last ijpj jlines of ib2 into znorthloc2 while allowing
5708	! for any trimming of domain (see earlier comments and diagram in
5709	! mpp_lbc_north_2d).
5710	znorthloc2(:,:) = 0 ! because of padding for nwidthmax
5711	DO ij = jpjglo - jeub + 1, ijpj, 1
5712	jj = nlcj - ijpj + ij
5713	znorthloc2(nldi:nlei,ij)=ib2(nldi:nlei,jj)
5714	END DO
5715
5716	IF (npolj /= 0 ) THEN
5717	! Build in proc 0 of ncomm_north the znorthgloio2
5718	znorthgloio2(:,:,:) = 0
5719	itaille=nwidthmax*ijpj
5720	CALL MPI_GATHER(znorthloc2,itaille,MPI_INTEGER, &
5721	znorthgloio2,itaille,MPI_INTEGER,0,&
5722	ncomm_north,ierr)
5723	ENDIF
5724
5725	IF (narea == north_root+1 ) THEN
5726	! recover the global north array
5727	ztab2(:,:) = 0
5728
5729	DO jr = 1, ndim_rank_north
5730	jproc=nrank_north(jr)+1
5731	ildi=nldit (jproc)
5732	ilei=nleit (jproc)
5733	iilb=pielb(jproc)
5734	!WRITE (,)'ARPDBG, jproc = ',jproc,' ildi, ilei, iilb and ijpj = ',&
5735	! ildi, ilei, iilb, ijpj
5736	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj) = &
5737	znorthgloio2(ildi:ilei,1:ijpj,jr)
5738	END DO
5739
5740
5741	! 2. North-Fold boundary conditions
5742	! ----------------------------------
5743
5744	SELECT CASE ( npolj )
5745
5746	CASE ( 3, 4 ) ! * North fold T-point pivot
5747
5748	ztab2( 1 ,ijpj) = 0
5749	ztab2(jpiglo,ijpj) = 0
5750
5751	SELECT CASE ( cd_type )
5752
5753	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
5754	DO ji = 2, jpiglo
5755	ijt = jpiglo-ji+2
5756	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2)
5757	END DO
5758	DO ji = jpiglo/2+1, jpiglo
5759	ijt = jpiglo-ji+2
5760	ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1)
5761	END DO
5762
5763	CASE ( 'U' ) ! U-point
5764	DO ji = 1, jpiglo-1
5765	iju = jpiglo-ji+1
5766	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-2)
5767	END DO
5768	DO ji = jpiglo/2, jpiglo-1
5769	iju = jpiglo-ji+1
5770	ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1)
5771	END DO
5772
5773	CASE ( 'V' ) ! V-point
5774	DO ji = 2, jpiglo
5775	ijt = jpiglo-ji+2
5776	ztab2(ji,ijpj-1) = isgn * ztab2(ijt,ijpj-2)
5777	ztab2(ji,ijpj ) = isgn * ztab2(ijt,ijpj-3)
5778	END DO
5779
5780	CASE ( 'F' , 'G' ) ! F-point
5781	DO ji = 1, jpiglo-1
5782	iju = jpiglo-ji+1
5783	ztab2(ji,ijpj-1) = isgn * ztab2(iju,ijpj-2)
5784	ztab2(ji,ijpj ) = isgn * ztab2(iju,ijpj-3)
5785	END DO
5786
5787	CASE ( 'I' ) ! ice U-V point
5788	ztab2(2,ijpj) = isgn * ztab2(3,ijpj-1)
5789	DO ji = 3, jpiglo
5790	iju = jpiglo - ji + 3
5791	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1)
5792	END DO
5793
5794	END SELECT
5795
5796	CASE ( 5, 6 ) ! * North fold F-point pivot
5797
5798	ztab2( 1 ,ijpj) = 0
5799	ztab2(jpiglo,ijpj) = 0
5800
5801	SELECT CASE ( cd_type )
5802
5803	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
5804	DO ji = 1, jpiglo
5805	ijt = jpiglo-ji+1
5806	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-1)
5807	END DO
5808
5809	CASE ( 'U' ) ! U-point
5810	DO ji = 1, jpiglo-1
5811	iju = jpiglo-ji
5812	ztab2(ji,ijpj) = isgn * ztab2(iju,ijpj-1)
5813	END DO
5814
5815	CASE ( 'V' ) ! V-point
5816	DO ji = 1, jpiglo
5817	ijt = jpiglo-ji+1
5818	ztab2(ji,ijpj) = isgn * ztab2(ijt,ijpj-2)
5819	END DO
5820	DO ji = jpiglo/2+1, jpiglo
5821	ijt = jpiglo-ji+1
5822	ztab2(ji,ijpjm1) = isgn * ztab2(ijt,ijpjm1)
5823	END DO
5824
5825	CASE ( 'F' , 'G' ) ! F-point
5826	DO ji = 1, jpiglo-1
5827	iju = jpiglo-ji
5828	ztab2(ji,ijpj ) = isgn * ztab2(iju,ijpj-2)
5829	END DO
5830	DO ji = jpiglo/2+1, jpiglo-1
5831	iju = jpiglo-ji
5832	ztab2(ji,ijpjm1) = isgn * ztab2(iju,ijpjm1)
5833	END DO
5834
5835	CASE ( 'I' ) ! ice U-V point
5836	ztab2( 2 ,ijpj) = 0
5837	DO ji = 2 , jpiglo-1
5838	ijt = jpiglo - ji + 2
5839	ztab2(ji,ijpj)= NINT(0.5 * ( ztab2(ji,ijpj-1) + &
5840	isgn * ztab2(ijt,ijpj-1) ))
5841	END DO
5842
5843	END SELECT
5844
5845	CASE DEFAULT ! * closed : the code probably never go through
5846
5847	SELECT CASE ( cd_type)
5848
5849	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5850	ztab2(:, 1 ) = 0
5851	ztab2(:,ijpj) = 0
5852
5853	CASE ( 'F' ) ! F-point
5854	ztab2(:,ijpj) = 0
5855
5856	CASE ( 'I' ) ! ice U-V point
5857	ztab2(:, 1 ) = 0
5858	ztab2(:,ijpj) = 0
5859
5860	END SELECT
5861
5862	END SELECT
5863
5864	! End of slab
5865	! ===========
5866
5867	!! Scatter back to ib2
5868	DO jr = 1, ndim_rank_north
5869	jproc=nrank_north(jr)+1
5870	ildi=nldit (jproc)
5871	ilei=nleit (jproc)
5872	iilb=pielb(jproc)
5873	znorthgloio2(ildi:ilei,1:ijpj,jr) = &
5874	ztab2(iilb:iilb+piesub(jproc)-1,1:ijpj)
5875	END DO
5876
5877	ENDIF ! only done on proc 0 of ncomm_north
5878
5879	IF ( npolj /= 0 ) THEN
5880	itaille=nwidthmax*ijpj
5881	CALL MPI_SCATTER(znorthgloio2,itaille,MPI_INTEGER, &
5882	znorthloc2, itaille,MPI_INTEGER, &
5883	0, ncomm_north, ierr)
5884	ENDIF
5885
5886	! put in the last ijpj jlines of ib2 from znorthloc2 while allowing
5887	! for any trimming of domain (see earlier comments and diagram in
5888	! mpp_lbc_north_2d).
5889	DO ij = jpjglo - jeub + 1, ijpj, 1
5890	jj = nlcj - ijpj + ij
5891	ib2(nldi:nlei,jj)= znorthloc2(nldi:nlei,ij)
5892	END DO
5893	WRITE(,) 'ARPDBG: finished in mpp_lbc_north_i2d'
5894
5895	#endif /* key_mpp_mpi */
5896
5897	END SUBROUTINE mpp_lbc_north_i2d
5898
5899	!=================================================================
5900
5901	SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
5902	!!---------------------------------------------------------------------
5903	!! * routine mpp_lbc_north_3d *
5904	!!
5905	!! ** Purpose :
5906	!! Ensure proper north fold horizontal bondary condition in mpp
5907	!! configuration in case of jpn1 > 1
5908	!!
5909	!! ** Method :
5910	!! Gather the 4 northern lines of the global domain on 1 processor
5911	!! and apply lbc north-fold on this sub array. Then scatter the
5912	!! fold array back to the processors.
5913	!!
5914	!! History :
5915	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5916	!! from lbc routine
5917	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp,
5918	!! coding rules of lbc_lnk
5919	!!----------------------------------------------------------------------
5920	USE par_oce, ONLY : jpni
5921	USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, nwidthmax
5922	USE mapcomm_mod, ONLY : pielb, piesub
5923	USE lib_mpp, ONLY : ctl_stop
5924	IMPLICIT none
5925	!! * Arguments
5926	CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points
5927	! ! = T, U, V, F or W gridp'ts
5928	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
5929	pt3d ! 3D array on which the boundary condition is applied
5930	REAL(wp), INTENT( in ) :: &
5931	psgn ! control of the sign change
5932	! ! = -1. , the sign is changed if north fold boundary
5933	! ! = 1. , the sign is kept if north fold boundary
5934
5935	!! * Local declarations
5936	INTEGER :: ijpj
5937	INTEGER :: ji, jj, jk, jr, jproc
5938	INTEGER :: ierr
5939	INTEGER :: ildi,ilei,iilb
5940	INTEGER :: ijpjm1,ij,ijt,iju
5941	INTEGER :: itaille
5942	!FTRANS ztab :I :I :z
5943	!FTRANS znorthgloio :I :I :z :
5944	!FTRANS znorthloc :I :I :z
5945	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab
5946	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
5947	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc
5948	!!----------------------------------------------------------------------
5949
5950	! If we get in this routine it's because : North fold condition and
5951	! mpp with more than one proc across i : we deal only with the North
5952	! condition
5953	#if defined key_mpp_mpi
5954
5955	ijpj = num_nfold_rows
5956	ijpjm1=ijpj - 1
5957
5958	IF(.not. ALLOCATED(ztab))THEN
5959
5960	ALLOCATE(ztab(jpiglo,ijpj,jpk), &
5961	znorthgloio(nwidthmax,ijpj,jpk,jpni), &
5962	znorthloc(nwidthmax,ijpj,jpk), &
5963	STAT=ierr)
5964	IF(ierr .ne. 0)THEN
5965	CALL ctl_stop( ' mpp_lbc_north_3d: memory allocation failed' )
5966	#if defined key_mpp_mpi
5967	CALL mpi_finalize( ierr )
5968	#endif
5969	STOP
5970	END IF
5971	END IF
5972
5973	CALL prof_region_begin(NORTH3DGATHER, "North3DGather", iprofStat)
5974
5975	! 0. Sign setting
5976	! ---------------
5977
5978	! Put the last ijpj jlines of pt3d into znorthloc while allowing
5979	! for any trimming of domain (see earlier comments and diagram in
5980	! mpp_lbc_north_2d).
5981	! Have to initialise all to zero in case chunks are missing due to domain
5982	! trimming
5983	znorthloc(:,:,:) = 0.0_wp
5984	#if defined key_z_first
5985	DO ij = jpjglo - jeub + 1, ijpj, 1
5986	jj = nlcj - ijpj + ij
5987	DO jk = 1, jpk
5988	#else
5989	DO jk = 1, jpk
5990	DO ij = jpjglo - jeub + 1, ijpj, 1
5991	jj = nlcj - ijpj + ij
5992	#endif
5993	znorthloc(nldi:nlei,ij,jk) = pt3d(nldi:nlei,jj,jk)
5994	END DO
5995	END DO
5996
5997
5998	IF (npolj /= 0 ) THEN
5999	! Build in proc 0 of ncomm_north the znorthgloio
6000
6001	#ifdef key_mpp_shmem
6002	not done : compiler error
6003	#elif defined key_mpp_mpi
6004	itaille=nwidthmaxjpkijpj
6005	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION, &
6006	znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
6007	0,ncomm_north,ierr)
6008	#endif
6009
6010	ENDIF
6011
6012	CALL prof_region_end(NORTH3DGATHER, iprofStat)
6013
6014	CALL prof_region_begin(NORTH3DAPPSYMM, "North3DApplySymm", iprofStat)
6015
6016	IF (narea == north_root+1 ) THEN
6017	! recover the global north array
6018	ztab(:,:,:) = 0_wp
6019
6020	DO jr = 1, ndim_rank_north
6021	jproc = nrank_north(jr) + 1
6022	ildi = nldit (jproc)
6023	ilei = nleit (jproc)
6024	iilb = pielb(jproc)
6025	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = &
6026	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr)
6027	END DO
6028
6029
6030	! Horizontal slab
6031	! ===============
6032	#if defined key_z_first
6033
6034	! 2. North-Fold boundary conditions
6035	! ----------------------------------
6036
6037	SELECT CASE ( npolj )
6038
6039	CASE ( 3, 4 ) ! * North fold T-point pivot
6040
6041	DO jk = 1, jpk
6042	ztab( 1 ,ijpj,jk) = 0.0_wp
6043	ztab(jpiglo,ijpj,jk) = 0.0_wp
6044	END DO
6045
6046	SELECT CASE ( cd_type )
6047
6048	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6049	DO ji = 2, jpiglo
6050	ijt = jpiglo-ji+2
6051	DO jk = 1, jpk
6052	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6053	END DO
6054	END DO
6055	DO ji = jpiglo/2+1, jpiglo
6056	ijt = jpiglo-ji+2
6057	DO jk = 1, jpk, 1
6058	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6059	END DO
6060	END DO
6061
6062	CASE ( 'U' ) ! U-point
6063	DO ji = 1, jpiglo-1
6064	iju = jpiglo-ji+1
6065	DO jk = 1, jpk, 1
6066	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
6067	END DO
6068	END DO
6069	DO ji = jpiglo/2, jpiglo-1
6070	iju = jpiglo-ji+1
6071	DO jk = 1, jpk, 1
6072	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6073	END DO
6074	END DO
6075
6076	CASE ( 'V' ) ! V-point
6077	DO ji = 2, jpiglo
6078	ijt = jpiglo-ji+2
6079	DO jk = 1, jpk, 1
6080	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
6081	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
6082	END DO
6083	END DO
6084
6085	CASE ( 'F' , 'G' ) ! F-point
6086	DO ji = 1, jpiglo-1
6087	iju = jpiglo-ji+1
6088	DO jk = 1, jpk, 1
6089	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
6090	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
6091	END DO
6092	END DO
6093
6094	END SELECT
6095
6096	CASE ( 5, 6 ) ! * North fold F-point pivot
6097
6098	DO jk = 1, jpk, 1
6099	ztab( 1 ,ijpj,jk) = 0._wp
6100	ztab(jpiglo,ijpj,jk) = 0._wp
6101	END DO
6102
6103	SELECT CASE ( cd_type )
6104
6105	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6106	DO ji = 1, jpiglo
6107	ijt = jpiglo-ji+1
6108	DO jk = 1, jpk, 1
6109	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
6110	END DO
6111	END DO
6112
6113	CASE ( 'U' ) ! U-point
6114	DO ji = 1, jpiglo-1
6115	iju = jpiglo-ji
6116	DO jk = 1, jpk, 1
6117	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
6118	END DO
6119	END DO
6120
6121	CASE ( 'V' ) ! V-point
6122	DO ji = 1, jpiglo
6123	ijt = jpiglo-ji+1
6124	DO jk = 1, jpk, 1
6125	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6126	END DO
6127	END DO
6128	DO ji = jpiglo/2+1, jpiglo
6129	ijt = jpiglo-ji+1
6130	DO jk = 1, jpk, 1
6131	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6132	END DO
6133	END DO
6134
6135	CASE ( 'F' , 'G' ) ! F-point
6136	DO ji = 1, jpiglo-1
6137	iju = jpiglo-ji
6138	DO jk = 1, jpk, 1
6139	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
6140	END DO
6141	END DO
6142	DO ji = jpiglo/2+1, jpiglo-1
6143	iju = jpiglo-ji
6144	DO jk = 1, jpk, 1
6145	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6146	END DO
6147	END DO
6148
6149	END SELECT
6150
6151	CASE DEFAULT ! * closed
6152
6153	SELECT CASE ( cd_type)
6154
6155	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6156	DO ji = 1, jpiglo, 1
6157	DO jk = 1, jpk, 1
6158	ztab(ji, 1 ,jk) = 0.0_wp
6159	ztab(ji,ijpj,jk) = 0.0_wp
6160	END DO
6161	END DO
6162
6163	CASE ( 'F' ) ! F-point
6164	DO ji = 1, jpiglo, 1
6165	DO jk = 1, jpk, 1
6166	ztab(ji,ijpj,jk) = 0.0_wp
6167	END DO
6168	END DO
6169
6170	END SELECT
6171
6172	END SELECT
6173
6174	! End of slab
6175	! ===========
6176	#else
6177	DO jk = 1, jpk
6178
6179
6180	! 2. North-Fold boundary conditions
6181	! ----------------------------------
6182
6183	SELECT CASE ( npolj )
6184
6185	CASE ( 3, 4 ) ! * North fold T-point pivot
6186
6187	ztab( 1 ,ijpj,jk) = 0.0_wp
6188	ztab(jpiglo,ijpj,jk) = 0.0_wp
6189
6190	SELECT CASE ( cd_type )
6191
6192	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6193	DO ji = 2, jpiglo
6194	ijt = jpiglo-ji+2
6195	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6196	END DO
6197	DO ji = jpiglo/2+1, jpiglo
6198	ijt = jpiglo-ji+2
6199	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6200	END DO
6201
6202	CASE ( 'U' ) ! U-point
6203	DO ji = 1, jpiglo-1
6204	iju = jpiglo-ji+1
6205	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
6206	END DO
6207	DO ji = jpiglo/2, jpiglo-1
6208	iju = jpiglo-ji+1
6209	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6210	END DO
6211
6212	CASE ( 'V' ) ! V-point
6213	DO ji = 2, jpiglo
6214	ijt = jpiglo-ji+2
6215	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
6216	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
6217	END DO
6218
6219	CASE ( 'F' , 'G' ) ! F-point
6220	DO ji = 1, jpiglo-1
6221	iju = jpiglo-ji+1
6222	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
6223	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
6224	END DO
6225
6226	END SELECT
6227
6228	CASE ( 5, 6 ) ! * North fold F-point pivot
6229
6230	ztab( 1 ,ijpj,jk) = 0._wp
6231	ztab(jpiglo,ijpj,jk) = 0._wp
6232
6233	SELECT CASE ( cd_type )
6234
6235	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6236	DO ji = 1, jpiglo
6237	ijt = jpiglo-ji+1
6238	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
6239	END DO
6240
6241	CASE ( 'U' ) ! U-point
6242	DO ji = 1, jpiglo-1
6243	iju = jpiglo-ji
6244	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
6245	END DO
6246
6247	CASE ( 'V' ) ! V-point
6248	DO ji = 1, jpiglo
6249	ijt = jpiglo-ji+1
6250	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
6251	END DO
6252	DO ji = jpiglo/2+1, jpiglo
6253	ijt = jpiglo-ji+1
6254	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
6255	END DO
6256
6257	CASE ( 'F' , 'G' ) ! F-point
6258	DO ji = 1, jpiglo-1
6259	iju = jpiglo-ji
6260	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
6261	END DO
6262	DO ji = jpiglo/2+1, jpiglo-1
6263	iju = jpiglo-ji
6264	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
6265	END DO
6266
6267	END SELECT
6268
6269	CASE DEFAULT ! * closed
6270
6271	SELECT CASE ( cd_type)
6272
6273	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6274	ztab(:, 1 ,jk) = 0.0_wp
6275	ztab(:,ijpj,jk) = 0.0_wp
6276
6277	CASE ( 'F' ) ! F-point
6278	ztab(:,ijpj,jk) = 0.0_wp
6279
6280	END SELECT
6281
6282	END SELECT
6283
6284	! End of slab
6285	! ===========
6286
6287	END DO
6288	#endif
6289
6290	!! Scatter back to pt3d
6291	DO jr = 1, ndim_rank_north
6292	jproc=nrank_north(jr)+1
6293	ildi=nldit (jproc)
6294	ilei=nleit (jproc)
6295	iilb=pielb(jproc)
6296	!ARPDBG - make loops explicit for performance?
6297	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = &
6298	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk)
6299	END DO
6300
6301	ENDIF ! only done on proc 0 of ncomm_north
6302
6303	CALL prof_region_end(NORTH3DAPPSYMM, iprofStat)
6304
6305	!ARPDBG - could do above on every 'northern' pe and then don't have to
6306	! do scatter below...
6307
6308	CALL prof_region_begin(NORTH3DSCATTER, "North3DScatter", iprofStat)
6309
6310	#ifdef key_mpp_shmem
6311	not done yet in shmem : compiler error
6312	#elif key_mpp_mpi
6313	IF ( npolj /= 0 ) THEN
6314	itaille=nwidthmaxjpkijpj
6315	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION, &
6316	znorthloc, itaille,MPI_DOUBLE_PRECISION, &
6317	0,ncomm_north,ierr)
6318	ENDIF
6319	#endif
6320
6321	! put in the last ijpj jlines of pt3d znorthloc while allowing
6322	! for any trimming of domain (see earlier comments and diagram in
6323	! mpp_lbc_north_2d).
6324	#if defined key_z_first
6325	DO ij = jpjglo - jeub + 1, ijpj, 1
6326	jj = nlcj - ijpj + ij
6327	DO jk = 1 , jpk
6328	#else
6329	DO jk = 1 , jpk
6330	DO ij = jpjglo - jeub + 1, ijpj, 1
6331	jj = nlcj - ijpj + ij
6332	#endif
6333	pt3d(nldi:nlei,jj,jk)= znorthloc(nldi:nlei,ij,jk)
6334	END DO
6335	END DO
6336
6337	CALL prof_region_end(NORTH3DSCATTER, iprofStat)
6338
6339	#endif /* key_mpp_mpi */
6340
6341	END SUBROUTINE mpp_lbc_north_3d
6342
6343	!===================================================================
6344
6345	SUBROUTINE mpp_lbc_north_i3d ( ib3, cd_type, isgn )
6346	!!---------------------------------------------------------------------
6347	!! * routine mpp_lbc_north_3d *
6348	!!
6349	!! ** Purpose :
6350	!! Ensure proper north fold horizontal bondary condition in mpp
6351	!! configuration in case of jpn1 > 1
6352	!!
6353	!! ** Method :
6354	!! Gather the 4 northern lines of the global domain on 1 processor
6355	!! and apply lbc north-fold on this sub array. Then scatter the
6356	!! fold array back to the processors.
6357	!!
6358	!! History :
6359	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
6360	!! from lbc routine
6361	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding
6362	!! rules of lbc_lnk
6363	!!----------------------------------------------------------------------
6364	USE par_oce, ONLY : jpni
6365	USE dom_oce, ONLY : nldi, nlei, nlcj, npolj, narea, nldit, nleit, &
6366	nwidthmax
6367	USE mapcomm_mod, ONLY : pielb, piesub
6368	USE lib_mpp, ONLY : ctl_stop
6369	IMPLICIT none
6370	!! * Arguments
6371	CHARACTER(len=1), INTENT( in ) :: cd_type ! nature of pt3d grid-points
6372	! ! = T, U, V, F or W gridp'ts
6373	INTEGER, DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
6374	ib3 ! 3D array on which the boundary condition is applied
6375	INTEGER, INTENT( in ) :: &
6376	isgn ! control of the sign change
6377	! ! = -1. , the sign is changed if north fold boundary
6378	! ! = 1. , the sign is kept if north fold boundary
6379
6380	!! * Local declarations
6381	INTEGER :: ijpj
6382	INTEGER :: ijpjm1
6383	INTEGER :: ii, ji, jj, jk, jr, jproc
6384	INTEGER :: ierr
6385	INTEGER :: ildi,ilei,iilb
6386	INTEGER :: ij,ijt,iju
6387	INTEGER :: itaille
6388
6389	!FTRANS ztab :I :I :z
6390	!FTRANS znorthgloio :I :I :z :
6391	!FTRANS znorthloc :I :I :z
6392	INTEGER, DIMENSION(:,:,:) , ALLOCATABLE :: ztab
6393	INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
6394	INTEGER, DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc
6395	!!----------------------------------------------------------------------
6396
6397	! If we get in this routine it s because : North fold condition and
6398	! mpp with more than one proc across i : we deal only with the North
6399	! condition
6400
6401	ijpj = num_nfold_rows
6402	ijpjm1 = ijpj - 1
6403
6404	IF(.not. ALLOCATED(ztab))THEN
6405
6406	ALLOCATE(ztab(jpiglo,ijpj,jpk), &
6407	znorthgloio(nwidthmax,ijpj,jpk,jpni), &
6408	znorthloc(nwidthmax,ijpj,jpk), &
6409	STAT=ierr)
6410	IF(ierr .ne. 0)THEN
6411	CALL ctl_stop('STOP','mpp_lbc_north_i3d: memory allocation failed' )
6412	END IF
6413	END IF
6414
6415	! 0. Sign setting
6416	! ---------------
6417
6418	! put in znorthloc the last ijpj jlines of pt3d while allowing
6419	! for any trimming of domain (see earlier comments and diagram in
6420	! mpp_lbc_north_2d).
6421	znorthloc(:,:,:) = 0 ! because of padding for nwidthmax and domain
6422	! trimming
6423	#if defined key_z_first
6424	DO ij = jpjglo - jeub + 1, ijpj, 1
6425	jj = nlcj - ijpj + ij
6426	DO jk = 1, jpk
6427	#else
6428	DO jk = 1, jpk
6429	DO ij = jpjglo - jeub + 1, ijpj, 1
6430	jj = nlcj - ijpj + ij
6431	#endif
6432	znorthloc(nldi:nlei,ij,jk) = ib3(nldi:nlei,jj,jk)
6433	END DO
6434	END DO
6435
6436
6437	IF (npolj /= 0 ) THEN
6438	! Build in proc 0 of ncomm_north the znorthgloio
6439	znorthgloio(:,:,:,:) = 0
6440
6441	#ifdef key_mpp_shmem
6442	not done : compiler error
6443	#elif defined key_mpp_mpi
6444	! All domains send this number of elements. Narrower domains
6445	! therefore send data padded with zeros
6446	itaille=nwidthmaxjpkijpj
6447	CALL MPI_GATHER(znorthloc, itaille,MPI_INTEGER, &
6448	znorthgloio,itaille,MPI_INTEGER, &
6449	0, ncomm_north, ierr)
6450	#endif
6451
6452	ENDIF
6453
6454	IF (narea == north_root+1 ) THEN
6455	! recover the global north array
6456	ztab(:,:,:) = 0
6457
6458	DO jr = 1, ndim_rank_north
6459	jproc = nrank_north(jr) + 1
6460	ildi = nldit (jproc)
6461	ilei = nleit (jproc)
6462	iilb = pielb(jproc)
6463	! ARPDBG explicit loops for performance?
6464	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk) = &
6465	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr)
6466	END DO
6467
6468
6469	#if defined key_z_first
6470	! 2. North-Fold boundary conditions
6471	! ----------------------------------
6472
6473	SELECT CASE ( npolj )
6474
6475	CASE ( 3, 4 ) ! * North fold T-point pivot
6476
6477	DO jk = 1, jpk, 1
6478	ztab( 1 ,ijpj,jk) = 0
6479	ztab(jpiglo,ijpj,jk) = 0
6480	END DO
6481
6482	SELECT CASE ( cd_type )
6483
6484	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6485	DO ji = 2, jpiglo
6486	ijt = jpiglo-ji+2
6487	DO jk = 1, jpk, 1
6488	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6489	END DO
6490	END DO
6491	DO ji = jpiglo/2+1, jpiglo
6492	ijt = jpiglo-ji+2
6493	DO jk = 1, jpk, 1
6494	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6495	END DO
6496	END DO
6497
6498	CASE ( 'U' ) ! U-point
6499	DO ji = 1, jpiglo-1
6500	iju = jpiglo-ji+1
6501	DO jk = 1, jpk, 1
6502	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk)
6503	END DO
6504	END DO
6505	DO ji = jpiglo/2, jpiglo-1
6506	iju = jpiglo-ji+1
6507	DO jk = 1, jpk, 1
6508	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6509	END DO
6510	END DO
6511
6512	CASE ( 'V' ) ! V-point
6513	DO ji = 2, jpiglo
6514	ijt = jpiglo-ji+2
6515	DO jk = 1, jpk, 1
6516	ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk)
6517	ztab(ji,ijpj ,jk) = isgn * ztab(ijt,ijpj-3,jk)
6518	END DO
6519	END DO
6520
6521	CASE ( 'F' , 'G' ) ! F-point
6522	DO ji = 1, jpiglo-1
6523	iju = jpiglo-ji+1
6524	DO jk = 1, jpk, 1
6525	ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk)
6526	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-3,jk)
6527	END DO
6528	END DO
6529
6530	END SELECT
6531
6532	CASE ( 5, 6 ) ! * North fold F-point pivot
6533
6534	DO jk = 1, jpk, 1
6535	ztab( 1 ,ijpj,jk) = 0
6536	ztab(jpiglo,ijpj,jk) = 0
6537	END DO
6538
6539	SELECT CASE ( cd_type )
6540
6541	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6542	DO ji = 1, jpiglo
6543	ijt = jpiglo-ji+1
6544	DO jk = 1, jpk, 1
6545	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk)
6546	END DO
6547	END DO
6548
6549	CASE ( 'U' ) ! U-point
6550	DO ji = 1, jpiglo-1
6551	iju = jpiglo-ji
6552	DO jk = 1, jpk, 1
6553	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk)
6554	END DO
6555	END DO
6556
6557	CASE ( 'V' ) ! V-point
6558	DO ji = 1, jpiglo
6559	ijt = jpiglo-ji+1
6560	DO jk = 1, jpk, 1
6561	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6562	END DO
6563	END DO
6564	DO ji = jpiglo/2+1, jpiglo
6565	ijt = jpiglo-ji+1
6566	DO jk = 1, jpk, 1
6567	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6568	END DO
6569	END DO
6570
6571	CASE ( 'F' , 'G' ) ! F-point
6572	DO ji = 1, jpiglo-1
6573	iju = jpiglo-ji
6574	DO jk = 1, jpk, 1
6575	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-2,jk)
6576	END DO
6577	END DO
6578	DO ji = jpiglo/2+1, jpiglo-1
6579	iju = jpiglo-ji
6580	DO jk = 1, jpk, 1
6581	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6582	END DO
6583	END DO
6584
6585	END SELECT
6586
6587	CASE DEFAULT ! * closed
6588
6589	SELECT CASE ( cd_type)
6590
6591	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6592	DO ji = 1, jpiglo, 1
6593	DO jk = 1, jpk, 1
6594	ztab(ji, 1 ,jk) = 0
6595	ztab(ji,ijpj,jk) = 0
6596	END DO
6597	END DO
6598
6599	CASE ( 'F' ) ! F-point
6600	DO ji = 1, jpiglo, 1
6601	DO jk = 1, jpk, 1
6602	ztab(ji,ijpj,jk) = 0
6603	END DO
6604	END DO
6605
6606	END SELECT
6607
6608	END SELECT
6609
6610	! End of slab
6611	! ===========
6612	#else
6613	! Horizontal slab
6614	! ===============
6615
6616	DO jk = 1, jpk
6617
6618
6619	! 2. North-Fold boundary conditions
6620	! ----------------------------------
6621
6622	SELECT CASE ( npolj )
6623
6624	CASE ( 3, 4 ) ! * North fold T-point pivot
6625
6626	ztab( 1 ,ijpj,jk) = 0
6627	ztab(jpiglo,ijpj,jk) = 0
6628
6629	SELECT CASE ( cd_type )
6630
6631	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6632	DO ji = 2, jpiglo
6633	ijt = jpiglo-ji+2
6634	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6635	END DO
6636	DO ji = jpiglo/2+1, jpiglo
6637	ijt = jpiglo-ji+2
6638	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6639	END DO
6640
6641	CASE ( 'U' ) ! U-point
6642	DO ji = 1, jpiglo-1
6643	iju = jpiglo-ji+1
6644	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-2,jk)
6645	END DO
6646	DO ji = jpiglo/2, jpiglo-1
6647	iju = jpiglo-ji+1
6648	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6649	END DO
6650
6651	CASE ( 'V' ) ! V-point
6652	DO ji = 2, jpiglo
6653	ijt = jpiglo-ji+2
6654	ztab(ji,ijpj-1,jk) = isgn * ztab(ijt,ijpj-2,jk)
6655	ztab(ji,ijpj ,jk) = isgn * ztab(ijt,ijpj-3,jk)
6656	END DO
6657
6658	CASE ( 'F' , 'G' ) ! F-point
6659	DO ji = 1, jpiglo-1
6660	iju = jpiglo-ji+1
6661	ztab(ji,ijpj-1,jk) = isgn * ztab(iju,ijpj-2,jk)
6662	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-3,jk)
6663	END DO
6664
6665	END SELECT
6666
6667	CASE ( 5, 6 ) ! * North fold F-point pivot
6668
6669	ztab( 1 ,ijpj,jk) = 0
6670	ztab(jpiglo,ijpj,jk) = 0
6671
6672	SELECT CASE ( cd_type )
6673
6674	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
6675	DO ji = 1, jpiglo
6676	ijt = jpiglo-ji+1
6677	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-1,jk)
6678	END DO
6679
6680	CASE ( 'U' ) ! U-point
6681	DO ji = 1, jpiglo-1
6682	iju = jpiglo-ji
6683	ztab(ji,ijpj,jk) = isgn * ztab(iju,ijpj-1,jk)
6684	END DO
6685
6686	CASE ( 'V' ) ! V-point
6687	DO ji = 1, jpiglo
6688	ijt = jpiglo-ji+1
6689	ztab(ji,ijpj,jk) = isgn * ztab(ijt,ijpj-2,jk)
6690	END DO
6691	DO ji = jpiglo/2+1, jpiglo
6692	ijt = jpiglo-ji+1
6693	ztab(ji,ijpjm1,jk) = isgn * ztab(ijt,ijpjm1,jk)
6694	END DO
6695
6696	CASE ( 'F' , 'G' ) ! F-point
6697	DO ji = 1, jpiglo-1
6698	iju = jpiglo-ji
6699	ztab(ji,ijpj ,jk) = isgn * ztab(iju,ijpj-2,jk)
6700	END DO
6701	DO ji = jpiglo/2+1, jpiglo-1
6702	iju = jpiglo-ji
6703	ztab(ji,ijpjm1,jk) = isgn * ztab(iju,ijpjm1,jk)
6704	END DO
6705
6706	END SELECT
6707
6708	CASE DEFAULT ! * closed
6709
6710	SELECT CASE ( cd_type)
6711
6712	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
6713	ztab(:, 1 ,jk) = 0
6714	ztab(:,ijpj,jk) = 0
6715
6716	CASE ( 'F' ) ! F-point
6717	ztab(:,ijpj,jk) = 0
6718
6719	END SELECT
6720
6721	END SELECT
6722
6723	! End of slab
6724	! ===========
6725
6726	END DO
6727	#endif
6728
6729	!! Scatter back to pt3d
6730	DO jr = 1, ndim_rank_north
6731	jproc=nrank_north(jr)+1
6732	ildi=nldit (jproc)
6733	ilei=nleit (jproc)
6734	iilb=pielb(jproc)
6735	! DO jk= 1, jpk
6736	! DO jj=1,ijpj
6737	! DO ji=ildi,ilei
6738	! znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk)
6739	! END DO
6740	! END DO
6741	! END DO
6742	! ARPDBG - what about halos?
6743	znorthgloio(ildi:ilei,1:ijpj,1:jpk,jr) = &
6744	ztab(iilb:iilb+piesub(jproc)-1,1:ijpj,1:jpk)
6745	END DO
6746
6747	ENDIF ! only done on proc 0 of ncomm_north
6748
6749	#ifdef key_mpp_shmem
6750	not done yet in shmem : compiler error
6751	#elif key_mpp_mpi
6752	IF ( npolj /= 0 ) THEN
6753	itaille=nwidthmaxjpkijpj
6754	CALL MPI_SCATTER(znorthgloio,itaille,MPI_INTEGER, &
6755	znorthloc, itaille,MPI_INTEGER, &
6756	0, ncomm_north, ierr)
6757	ENDIF
6758	#endif
6759
6760	! put in the last ijpj jlines of pt3d znorthloc while allowing
6761	! for any trimming of domain (see earlier comments and diagram in
6762	! mpp_lbc_north_2d).
6763	#if defined key_z_first
6764	DO ij = jpjglo - jeub + 1, ijpj, 1
6765	jj = nlcj - ijpj + ij
6766	DO ii = nldi, nlei, 1
6767	DO jk = 1 , jpk
6768	#else
6769	DO jk = 1 , jpk
6770	DO ij = jpjglo - jeub + 1, ijpj, 1
6771	jj = nlcj - ijpj + ij
6772	DO ii = nldi, nlei, 1
6773	#endif
6774	ib3(ii,jj,jk)= znorthloc(ii,ij,jk)
6775	END DO
6776	END DO
6777	END DO
6778
6779	END SUBROUTINE mpp_lbc_north_i3d
6780
6781	!====================================================================
6782
6783	END MODULE exchmod
6784
6785	! Copy n contiguous real*8 elements from a to b.
6786	! We expect the compiler to optimise this into a call
6787	! to the system memory copy routine.
6788
6789	SUBROUTINE do_real8_copy( n, a, b )
6790	IMPLICIT none
6791
6792	! arguments
6793	INTEGER, INTENT(in) :: n
6794	REAL*8, dimension(n), INTENT(in ) :: a
6795	REAL*8, DIMENSION(n), INTENT(out) :: b
6796
6797	! local variables
6798	integer :: i
6799
6800	do i=1,n
6801	b(i) = a(i)
6802	end do
6803
6804	END SUBROUTINE do_real8_copy

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

Download in other formats: