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

Last change on this file since 4400 was 4400, checked in by trackstand2, 10 years ago
Replace jpk with jpkf in bound_exch_generic. Turn on test timing of exchanges
File size: 230.1 KB

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

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

Download in other formats: