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

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

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

Download in other formats: