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.

lib_mpp.F90 in branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8568

Last change on this file since 8568 was 8568, checked in by gm, 7 years ago
#1911 (ENHANCE-09): PART I.2 - _NONE option + remove zts + see associated wiki page
Property svn:keywords set to `Id`
File size: 187.1 KB

Line
1	MODULE lib_mpp
2	!!======================================================================
3	!! * MODULE lib_mpp *
4	!! Ocean numerics: massively parallel processing library
5	!!=====================================================================
6	!! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) Original code
7	!! 7.0 ! 1997 (A.M. Treguier) SHMEM additions
8	!! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
9	!! ! 1998 (J.M. Molines) Open boundary conditions
10	!! NEMO 1.0 ! 2003 (J.M. Molines, G. Madec) F90, free form
11	!! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d)
12	!! - ! 2004 (R. Bourdalle Badie) isend option in mpi
13	!! ! 2004 (J.M. Molines) minloc, maxloc
14	!! - ! 2005 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
15	!! - ! 2005 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
16	!! - ! 2005 (R. Benshila, G. Madec) add extra halo case
17	!! - ! 2008 (R. Benshila) add mpp_ini_ice
18	!! 3.2 ! 2009 (R. Benshila) SHMEM suppression, north fold in lbc_nfd
19	!! 3.2 ! 2009 (O. Marti) add mpp_ini_znl
20	!! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager
21	!! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',
22	!! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update
23	!! the mppobc routine to optimize the BDY and OBC communications
24	!! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables
25	!! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
26	!! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max
27	!! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension)
28	!!----------------------------------------------------------------------
29
30	!!----------------------------------------------------------------------
31	!! ctl_stop : update momentum and tracer Kz from a tke scheme
32	!! ctl_warn : initialization, namelist read, and parameters control
33	!! ctl_opn : Open file and check if required file is available.
34	!! ctl_nam : Prints informations when an error occurs while reading a namelist
35	!! get_unit : give the index of an unused logical unit
36	!!----------------------------------------------------------------------
37	#if defined key_mpp_mpi
38	!!----------------------------------------------------------------------
39	!! 'key_mpp_mpi' MPI massively parallel processing library
40	!!----------------------------------------------------------------------
41	!! lib_mpp_alloc : allocate mpp arrays
42	!! mynode : indentify the processor unit
43	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
44	!! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays
45	!! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
46	!! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
47	!! mpprecv :
48	!! mppsend :
49	!! mppscatter :
50	!! mppgather :
51	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
52	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
53	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
54	!! mpp_minloc :
55	!! mpp_maxloc :
56	!! mppsync :
57	!! mppstop :
58	!! mpp_ini_north : initialisation of north fold
59	!! mpp_lbc_north : north fold processors gathering
60	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
61	!! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs
62	!!----------------------------------------------------------------------
63	USE dom_oce ! ocean space and time domain
64	USE lbcnfd ! north fold treatment
65	USE in_out_manager ! I/O manager
66	USE wrk_nemo ! work arrays
67
68	IMPLICIT NONE
69	PRIVATE
70
71	PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam
72	PUBLIC mynode, mppstop, mppsync, mpp_comm_free
73	PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
74	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
75	PUBLIC mpp_max_multiple
76	PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
77	PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple
78	PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d
79	PUBLIC mppscatter, mppgather
80	PUBLIC mpp_ini_ice, mpp_ini_znl
81	PUBLIC mppsize
82	PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines
83	PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
84	PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb
85	PUBLIC mpprank
86
87	TYPE arrayptr
88	REAL(wp), DIMENSION (:,:), POINTER :: pt2d
89	END TYPE arrayptr
90	!
91	PUBLIC arrayptr
92
93	!! * Interfaces
94	!! define generic interface for these routine as they are called sometimes
95	!! with scalar arguments instead of array arguments, which causes problems
96	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
97	INTERFACE mpp_min
98	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
99	END INTERFACE
100	INTERFACE mpp_max
101	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
102	END INTERFACE
103	INTERFACE mpp_sum
104	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
105	& mppsum_realdd, mppsum_a_realdd
106	END INTERFACE
107	INTERFACE mpp_lbc_north
108	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
109	END INTERFACE
110	INTERFACE mpp_minloc
111	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
112	END INTERFACE
113	INTERFACE mpp_maxloc
114	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
115	END INTERFACE
116	INTERFACE mpp_max_multiple
117	MODULE PROCEDURE mppmax_real_multiple
118	END INTERFACE
119
120	!! ========================= !!
121	!! MPI variable definition !!
122	!! ========================= !!
123	!$AGRIF_DO_NOT_TREAT
124	INCLUDE 'mpif.h'
125	!$AGRIF_END_DO_NOT_TREAT
126
127	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
128
129	INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)
130
131	INTEGER :: mppsize ! number of process
132	INTEGER :: mpprank ! process number [ 0 - size-1 ]
133	!$AGRIF_DO_NOT_TREAT
134	INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator
135	!$AGRIF_END_DO_NOT_TREAT
136
137	INTEGER :: MPI_SUMDD
138
139	! variables used in case of sea-ice
140	INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in limthd)
141	INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology)
142	INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)
143	INTEGER :: ndim_rank_ice ! number of 'ice' processors
144	INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm
145	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice
146
147	! variables used for zonal integration
148	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
149	LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row
150	INTEGER :: ngrp_znl ! group ID for the znl processors
151	INTEGER :: ndim_rank_znl ! number of processors on the same zonal average
152	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain
153
154	! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
155	INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors
156	INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors
157	INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold)
158	INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north
159	INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !)
160	INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line
161	INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm
162	INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north
163
164	! Type of send : standard, buffered, immediate
165	CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend)
166	LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I')
167	INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend
168
169	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend
170
171	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms
172	LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms
173
174	!!----------------------------------------------------------------------
175	!! NEMO/OPA 4.0 , NEMO Consortium (2017)
176	!! $Id$
177	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
178	!!----------------------------------------------------------------------
179	CONTAINS
180
181	FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm )
182	!!----------------------------------------------------------------------
183	!! * routine mynode *
184	!!
185	!! ** Purpose : Find processor unit
186	!!----------------------------------------------------------------------
187	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt !
188	CHARACTER(len=*) , INTENT(in ) :: ldname !
189	INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist
190	INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist
191	INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output
192	INTEGER , INTENT(inout) :: kstop ! stop indicator
193	INTEGER , OPTIONAL , INTENT(in ) :: localComm !
194	!
195	INTEGER :: mynode, ierr, code, ji, ii, ios
196	LOGICAL :: mpi_was_called
197	!
198	NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
199	!!----------------------------------------------------------------------
200	!
201	ii = 1
202	WRITE(ldtxt(ii),*) ; ii = ii + 1
203	WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1
204	WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1
205	!
206	REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables
207	READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901)
208	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp )
209	!
210	REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables
211	READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 )
212	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp )
213	!
214	! ! control print
215	WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1
216	WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
217	WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1
218	!
219	#if defined key_agrif
220	IF( .NOT. Agrif_Root() ) THEN
221	jpni = Agrif_Parent(jpni )
222	jpnj = Agrif_Parent(jpnj )
223	jpnij = Agrif_Parent(jpnij)
224	ENDIF
225	#endif
226	!
227	IF( jpnij < 1 ) THEN ! If jpnij is not specified in namelist then we calculate it
228	jpnij = jpni * jpnj ! this means there will be no land cutting out.
229	ENDIF
230
231	IF( jpni < 1 .OR. jpnj < 1 ) THEN
232	WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1
233	ELSE
234	WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1
235	WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1
236	WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1
237	ENDIF
238
239	WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1
240
241	CALL mpi_initialized ( mpi_was_called, code )
242	IF( code /= MPI_SUCCESS ) THEN
243	DO ji = 1, SIZE(ldtxt)
244	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
245	END DO
246	WRITE(*, cform_err)
247	WRITE(, ) 'lib_mpp: Error in routine mpi_initialized'
248	CALL mpi_abort( mpi_comm_world, code, ierr )
249	ENDIF
250
251	IF( mpi_was_called ) THEN
252	!
253	SELECT CASE ( cn_mpi_send )
254	CASE ( 'S' ) ! Standard mpi send (blocking)
255	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
256	CASE ( 'B' ) ! Buffer mpi send (blocking)
257	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
258	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
259	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
260	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
261	l_isend = .TRUE.
262	CASE DEFAULT
263	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
264	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
265	kstop = kstop + 1
266	END SELECT
267	!
268	ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN
269	WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1
270	WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1
271	kstop = kstop + 1
272	ELSE
273	SELECT CASE ( cn_mpi_send )
274	CASE ( 'S' ) ! Standard mpi send (blocking)
275	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
276	CALL mpi_init( ierr )
277	CASE ( 'B' ) ! Buffer mpi send (blocking)
278	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
279	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
280	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
281	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
282	l_isend = .TRUE.
283	CALL mpi_init( ierr )
284	CASE DEFAULT
285	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
286	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
287	kstop = kstop + 1
288	END SELECT
289	!
290	ENDIF
291
292	IF( PRESENT(localComm) ) THEN
293	IF( Agrif_Root() ) THEN
294	mpi_comm_opa = localComm
295	ENDIF
296	ELSE
297	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
298	IF( code /= MPI_SUCCESS ) THEN
299	DO ji = 1, SIZE(ldtxt)
300	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
301	END DO
302	WRITE(*, cform_err)
303	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
304	CALL mpi_abort( mpi_comm_world, code, ierr )
305	ENDIF
306	ENDIF
307
308	#if defined key_agrif
309	IF( Agrif_Root() ) THEN
310	CALL Agrif_MPI_Init(mpi_comm_opa)
311	ELSE
312	CALL Agrif_MPI_set_grid_comm(mpi_comm_opa)
313	ENDIF
314	#endif
315
316	CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
317	CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
318	mynode = mpprank
319
320	IF( mynode == 0 ) THEN
321	CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
322	WRITE(kumond, nammpp)
323	ENDIF
324	!
325	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
326	!
327	END FUNCTION mynode
328
329
330	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
331	!!----------------------------------------------------------------------
332	!! * routine mpp_lnk_3d *
333	!!
334	!! ** Purpose : Message passing manadgement
335	!!
336	!! ** Method : Use mppsend and mpprecv function for passing mask
337	!! between processors following neighboring subdomains.
338	!! domain parameters
339	!! nlci : first dimension of the local subdomain
340	!! nlcj : second dimension of the local subdomain
341	!! nbondi : mark for "east-west local boundary"
342	!! nbondj : mark for "north-south local boundary"
343	!! noea : number for local neighboring processors
344	!! nowe : number for local neighboring processors
345	!! noso : number for local neighboring processors
346	!! nono : number for local neighboring processors
347	!!
348	!! ** Action : ptab with update value at its periphery
349	!!----------------------------------------------------------------------
350	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
351	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
352	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary
353	CHARACTER(len=3), OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only
354	REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries)
355	!
356	INTEGER :: ji, jj, jk, jl ! dummy loop indices
357	INTEGER :: ipk ! 3rd dimension of the input array
358	INTEGER :: imigr, iihom, ijhom ! temporary integers
359	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
360	REAL(wp) :: zland
361	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
362	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north
363	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east
364	!!----------------------------------------------------------------------
365	!
366	ipk = SIZE( ptab, 3 )
367	!
368	ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2), &
369	& zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2) )
370
371	!
372	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
373	ELSE ; zland = 0._wp ! zero by default
374	ENDIF
375
376	! 1. standard boundary treatment
377	! ------------------------------
378	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
379	!
380	! WARNING ptab is defined only between nld and nle
381	DO jk = 1, ipk
382	DO jj = nlcj+1, jpj ! added line(s) (inner only)
383	ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk)
384	ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk)
385	ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk)
386	END DO
387	DO ji = nlci+1, jpi ! added column(s) (full)
388	ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk)
389	ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk)
390	ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk)
391	END DO
392	END DO
393	!
394	ELSE ! standard close or cyclic treatment
395	!
396	! ! East-West boundaries
397	! !* Cyclic
398	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
399	ptab( 1 ,:,:) = ptab(jpim1,:,:)
400	ptab(jpi,:,:) = ptab( 2 ,:,:)
401	ELSE !* closed
402	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
403	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
404	ENDIF
405	! ! North-South boundaries
406	! !* cyclic (only with no mpp j-split)
407	IF( nbondj == 2 .AND. jperio == 7 ) THEN
408	ptab(:,1 , :) = ptab(:, jpjm1,:)
409	ptab(:,jpj,:) = ptab(:, 2,:)
410	ELSE !* closed
411	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point
412	ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north
413	ENDIF
414	!
415	ENDIF
416
417	! 2. East and west directions exchange
418	! ------------------------------------
419	! we play with the neigbours AND the row number because of the periodicity
420	!
421	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
422	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
423	iihom = nlci-nreci
424	DO jl = 1, jpreci
425	zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
426	zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
427	END DO
428	END SELECT
429	!
430	! ! Migrations
431	imigr = jpreci * jpj * ipk
432	!
433	SELECT CASE ( nbondi )
434	CASE ( -1 )
435	CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
436	CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
437	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
438	CASE ( 0 )
439	CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
440	CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
441	CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
442	CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
443	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
444	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
445	CASE ( 1 )
446	CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
447	CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
448	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
449	END SELECT
450	!
451	! ! Write Dirichlet lateral conditions
452	iihom = nlci-jpreci
453	!
454	SELECT CASE ( nbondi )
455	CASE ( -1 )
456	DO jl = 1, jpreci
457	ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
458	END DO
459	CASE ( 0 )
460	DO jl = 1, jpreci
461	ptab(jl ,:,:) = zt3we(:,jl,:,2)
462	ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
463	END DO
464	CASE ( 1 )
465	DO jl = 1, jpreci
466	ptab(jl ,:,:) = zt3we(:,jl,:,2)
467	END DO
468	END SELECT
469
470	! 3. North and south directions
471	! -----------------------------
472	! always closed : we play only with the neigbours
473	!
474	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
475	ijhom = nlcj-nrecj
476	DO jl = 1, jprecj
477	zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
478	zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
479	END DO
480	ENDIF
481	!
482	! ! Migrations
483	imigr = jprecj * jpi * ipk
484	!
485	SELECT CASE ( nbondj )
486	CASE ( -1 )
487	CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
488	CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
489	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
490	CASE ( 0 )
491	CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
492	CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
493	CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
494	CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
495	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
496	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )
497	CASE ( 1 )
498	CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
499	CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
500	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
501	END SELECT
502	!
503	! ! Write Dirichlet lateral conditions
504	ijhom = nlcj-jprecj
505	!
506	SELECT CASE ( nbondj )
507	CASE ( -1 )
508	DO jl = 1, jprecj
509	ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
510	END DO
511	CASE ( 0 )
512	DO jl = 1, jprecj
513	ptab(:,jl ,:) = zt3sn(:,jl,:,2)
514	ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
515	END DO
516	CASE ( 1 )
517	DO jl = 1, jprecj
518	ptab(:,jl,:) = zt3sn(:,jl,:,2)
519	END DO
520	END SELECT
521
522	! 4. north fold treatment
523	! -----------------------
524	!
525	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
526	!
527	SELECT CASE ( jpni )
528	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
529	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
530	END SELECT
531	!
532	ENDIF
533	!
534	DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
535	!
536	END SUBROUTINE mpp_lnk_3d
537
538
539	SUBROUTINE mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp, pval )
540	!!----------------------------------------------------------------------
541	!! * routine mpp_lnk_2d_multiple *
542	!!
543	!! ** Purpose : Message passing management for multiple 2d arrays
544	!!
545	!! ** Method : Use mppsend and mpprecv function for passing mask
546	!! between processors following neighboring subdomains.
547	!! domain parameters
548	!! nlci : first dimension of the local subdomain
549	!! nlcj : second dimension of the local subdomain
550	!! nbondi : mark for "east-west local boundary"
551	!! nbondj : mark for "north-south local boundary"
552	!! noea : number for local neighboring processors
553	!! nowe : number for local neighboring processors
554	!! noso : number for local neighboring processors
555	!! nono : number for local neighboring processors
556	!!----------------------------------------------------------------------
557	TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields
558	CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! nature of pt2d_array grid-points
559	REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! sign used across the north fold boundary
560	INTEGER , INTENT(in ) :: kfld ! number of pt2d arrays
561	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
562	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
563	!
564	INTEGER :: ji, jj, jl, jf ! dummy loop indices
565	INTEGER :: imigr, iihom, ijhom ! temporary integers
566	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
567	REAL(wp) :: zland
568	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
569	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north
570	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east
571	!!----------------------------------------------------------------------
572	!
573	ALLOCATE( zt2ns(jpi,jprecj,2kfld), zt2sn(jpi,jprecj,2kfld), &
574	& zt2ew(jpj,jpreci,2kfld), zt2we(jpj,jpreci,2kfld) )
575	!
576	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
577	ELSE ; zland = 0._wp ! zero by default
578	ENDIF
579
580	! 1. standard boundary treatment
581	! ------------------------------
582	!
583	!First Array
584	DO jf = 1 , kfld
585	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
586	!
587	! WARNING pt2d is defined only between nld and nle
588	DO jj = nlcj+1, jpj ! added line(s) (inner only)
589	pt2d_array(jf)%pt2d(nldi :nlei , jj) = pt2d_array(jf)%pt2d(nldi:nlei, nlej)
590	pt2d_array(jf)%pt2d(1 :nldi-1, jj) = pt2d_array(jf)%pt2d(nldi , nlej)
591	pt2d_array(jf)%pt2d(nlei+1:nlci , jj) = pt2d_array(jf)%pt2d( nlei, nlej)
592	END DO
593	DO ji = nlci+1, jpi ! added column(s) (full)
594	pt2d_array(jf)%pt2d(ji, nldj :nlej ) = pt2d_array(jf)%pt2d(nlei, nldj:nlej)
595	pt2d_array(jf)%pt2d(ji, 1 :nldj-1) = pt2d_array(jf)%pt2d(nlei, nldj )
596	pt2d_array(jf)%pt2d(ji, nlej+1:jpj ) = pt2d_array(jf)%pt2d(nlei, nlej)
597	END DO
598	!
599	ELSE ! standard close or cyclic treatment
600	!
601	! ! East-West boundaries
602	IF( nbondi == 2 .AND. & !* Cyclic
603	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
604	pt2d_array(jf)%pt2d( 1 , : ) = pt2d_array(jf)%pt2d( jpim1, : ) ! west
605	pt2d_array(jf)%pt2d( jpi , : ) = pt2d_array(jf)%pt2d( 2 , : ) ! east
606	ELSE !* Closed
607	IF( .NOT. type_array(jf) == 'F' ) pt2d_array(jf)%pt2d( 1 : jpreci,:) = zland ! south except F-point
608	pt2d_array(jf)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north
609	ENDIF
610	! ! North-South boundaries
611	! !* Cyclic
612	IF( nbondj == 2 .AND. jperio == 7 ) THEN
613	pt2d_array(jf)%pt2d(:, 1 ) = pt2d_array(jf)%pt2d(:, jpjm1 )
614	pt2d_array(jf)%pt2d(:, jpj ) = pt2d_array(jf)%pt2d(:, 2 )
615	ELSE !* Closed
616	IF( .NOT. type_array(jf) == 'F' ) pt2d_array(jf)%pt2d(:, 1:jprecj ) = zland ! south except F-point
617	pt2d_array(jf)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north
618	ENDIF
619	ENDIF
620	END DO
621
622	! 2. East and west directions exchange
623	! ------------------------------------
624	! we play with the neigbours AND the row number because of the periodicity
625	!
626	DO jf = 1 , kfld
627	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
628	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
629	iihom = nlci-nreci
630	DO jl = 1, jpreci
631	zt2ew( : , jl , jf ) = pt2d_array(jf)%pt2d( jpreci+jl , : )
632	zt2we( : , jl , jf ) = pt2d_array(jf)%pt2d( iihom +jl , : )
633	END DO
634	END SELECT
635	END DO
636	!
637	! ! Migrations
638	imigr = jpreci * jpj
639	!
640	SELECT CASE ( nbondi )
641	CASE ( -1 )
642	CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req1 )
643	CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea )
644	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
645	CASE ( 0 )
646	CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 )
647	CALL mppsend( 2, zt2we(1,1,1), kfld*imigr, noea, ml_req2 )
648	CALL mpprecv( 1, zt2ew(1,1,kfld+1), kfld*imigr, noea )
649	CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe )
650	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
651	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
652	CASE ( 1 )
653	CALL mppsend( 1, zt2ew(1,1,1), kfld*imigr, nowe, ml_req1 )
654	CALL mpprecv( 2, zt2we(1,1,kfld+1), kfld*imigr, nowe )
655	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
656	END SELECT
657	!
658	! ! Write Dirichlet lateral conditions
659	iihom = nlci - jpreci
660	!
661
662	DO jf = 1 , kfld
663	SELECT CASE ( nbondi )
664	CASE ( -1 )
665	DO jl = 1, jpreci
666	pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf)
667	END DO
668	CASE ( 0 )
669	DO jl = 1, jpreci
670	pt2d_array(jf)%pt2d( jl ,:) = zt2we(:,jl,kfld+jf)
671	pt2d_array(jf)%pt2d( iihom+jl ,:) = zt2ew(:,jl,kfld+jf)
672	END DO
673	CASE ( 1 )
674	DO jl = 1, jpreci
675	pt2d_array(jf)%pt2d( jl ,:)= zt2we(:,jl,kfld+jf)
676	END DO
677	END SELECT
678	END DO
679
680	! 3. North and south directions
681	! -----------------------------
682	! always closed : we play only with the neigbours
683	!
684	!First Array
685	DO jf = 1 , kfld
686	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
687	ijhom = nlcj-nrecj
688	DO jl = 1, jprecj
689	zt2sn(:,jl,jf) = pt2d_array(jf)%pt2d(:, ijhom +jl )
690	zt2ns(:,jl,jf) = pt2d_array(jf)%pt2d(:, jprecj+jl )
691	END DO
692	ENDIF
693	END DO
694	!
695	! ! Migrations
696	imigr = jprecj * jpi
697	!
698	SELECT CASE ( nbondj )
699	CASE ( -1 )
700	CALL mppsend( 4, zt2sn(1,1, 1), kfld*imigr, nono, ml_req1 )
701	CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono )
702	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
703	CASE ( 0 )
704	CALL mppsend( 3, zt2ns(1,1, 1), kfld*imigr, noso, ml_req1 )
705	CALL mppsend( 4, zt2sn(1,1, 1), kfld*imigr, nono, ml_req2 )
706	CALL mpprecv( 3, zt2ns(1,1,kfld+1), kfld*imigr, nono )
707	CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso )
708	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
709	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
710	CASE ( 1 )
711	CALL mppsend( 3, zt2ns(1,1, 1), kfld*imigr, noso, ml_req1 )
712	CALL mpprecv( 4, zt2sn(1,1,kfld+1), kfld*imigr, noso )
713	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
714	END SELECT
715	!
716	! ! Write Dirichlet lateral conditions
717	ijhom = nlcj - jprecj
718	!
719	DO jf = 1 , kfld
720	SELECT CASE ( nbondj )
721	CASE ( -1 )
722	DO jl = 1, jprecj
723	pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf )
724	END DO
725	CASE ( 0 )
726	DO jl = 1, jprecj
727	pt2d_array(jf)%pt2d(:, jl ) = zt2sn(:,jl, kfld+jf )
728	pt2d_array(jf)%pt2d(:, ijhom+jl ) = zt2ns(:,jl, kfld+jf )
729	END DO
730	CASE ( 1 )
731	DO jl = 1, jprecj
732	pt2d_array(jf)%pt2d(:, jl ) = zt2sn(:,jl, kfld+jf )
733	END DO
734	END SELECT
735	END DO
736
737	! 4. north fold treatment
738	! -----------------------
739	!
740	IF( npolj /= 0 .AND. .NOT.PRESENT(cd_mpp) ) THEN
741	!
742	SELECT CASE ( jpni )
743	CASE ( 1 )
744	DO jf = 1, kfld
745	CALL lbc_nfd( pt2d_array(jf)%pt2d(:,:), type_array(jf), psgn_array(jf) ) ! only 1 northern proc, no mpp
746	END DO
747	CASE DEFAULT
748	CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, kfld ) ! for all northern procs.
749	END SELECT
750	!
751	ENDIF
752	!
753	DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
754	!
755	END SUBROUTINE mpp_lnk_2d_multiple
756
757
758	SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, kfld )
759	!!---------------------------------------------------------------------
760	REAL(wp) , DIMENSION(:,:), TARGET, INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
761	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points
762	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary
763	TYPE(arrayptr) , DIMENSION(:) , INTENT(inout) :: pt2d_array !
764	CHARACTER(len=1), DIMENSION(:) , INTENT(inout) :: type_array ! nature of pt2d_array array grid-points
765	REAL(wp) , DIMENSION(:) , INTENT(inout) :: psgn_array ! sign used across the north fold boundary
766	INTEGER , INTENT(inout) :: kfld !
767	!!---------------------------------------------------------------------
768	!
769	kfld = kfld + 1
770	pt2d_array(kfld)%pt2d => pt2d
771	type_array(kfld) = cd_type
772	psgn_array(kfld) = psgn
773	!
774	END SUBROUTINE load_array
775
776
777	SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC &
778	& , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF &
779	& , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)
780	!!---------------------------------------------------------------------
781	REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA ! 2D arrays on which the lbc is applied
782	REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE
783	REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI
784	CHARACTER(len=1) , INTENT(in ) :: cd_typeA ! nature of pt2D. array grid-points
785	CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE
786	CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI
787	REAL(wp) , INTENT(in ) :: psgnA ! sign used across the north fold
788	REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE
789	REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI
790	CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only
791	REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries)
792	!!
793	INTEGER :: kfld
794	TYPE(arrayptr) , DIMENSION(9) :: pt2d_array
795	CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of pt2d array grid-points
796	REAL(wp) , DIMENSION(9) :: psgn_array ! sign used across the north fold boundary
797	!!---------------------------------------------------------------------
798	!
799	kfld = 0
800	!
801	! ! Load the first array
802	CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, kfld )
803	!
804	! ! Look if more arrays are added
805	IF( PRESENT(psgnB) ) CALL load_array( pt2dB, cd_typeB, psgnB, pt2d_array, type_array, psgn_array, kfld )
806	IF( PRESENT(psgnC) ) CALL load_array( pt2dC, cd_typeC, psgnC, pt2d_array, type_array, psgn_array, kfld )
807	IF( PRESENT(psgnD) ) CALL load_array( pt2dD, cd_typeD, psgnD, pt2d_array, type_array, psgn_array, kfld )
808	IF( PRESENT(psgnE) ) CALL load_array( pt2dE, cd_typeE, psgnE, pt2d_array, type_array, psgn_array, kfld )
809	IF( PRESENT(psgnF) ) CALL load_array( pt2dF, cd_typeF, psgnF, pt2d_array, type_array, psgn_array, kfld )
810	IF( PRESENT(psgnG) ) CALL load_array( pt2dG, cd_typeG, psgnG, pt2d_array, type_array, psgn_array, kfld )
811	IF( PRESENT(psgnH) ) CALL load_array( pt2dH, cd_typeH, psgnH, pt2d_array, type_array, psgn_array, kfld )
812	IF( PRESENT(psgnI) ) CALL load_array( pt2dI, cd_typeI, psgnI, pt2d_array, type_array, psgn_array, kfld )
813	!
814	CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, kfld, cd_mpp,pval )
815	!
816	END SUBROUTINE mpp_lnk_2d_9
817
818
819	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
820	!!----------------------------------------------------------------------
821	!! * routine mpp_lnk_2d *
822	!!
823	!! ** Purpose : Message passing manadgement for 2d array
824	!!
825	!! ** Method : Use mppsend and mpprecv function for passing mask
826	!! between processors following neighboring subdomains.
827	!! domain parameters
828	!! nlci : first dimension of the local subdomain
829	!! nlcj : second dimension of the local subdomain
830	!! nbondi : mark for "east-west local boundary"
831	!! nbondj : mark for "north-south local boundary"
832	!! noea : number for local neighboring processors
833	!! nowe : number for local neighboring processors
834	!! noso : number for local neighboring processors
835	!! nono : number for local neighboring processors
836	!!
837	!!----------------------------------------------------------------------
838	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
839	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points
840	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary
841	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
842	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
843	!!
844	INTEGER :: ji, jj, jl ! dummy loop indices
845	INTEGER :: imigr, iihom, ijhom ! temporary integers
846	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
847	REAL(wp) :: zland
848	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
849	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north
850	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east
851	!!----------------------------------------------------------------------
852	!
853	ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &
854	& zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )
855	!
856	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
857	ELSE ; zland = 0._wp ! zero by default
858	ENDIF
859
860	! 1. standard boundary treatment
861	! ------------------------------
862	!
863	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
864	!
865	! WARNING pt2d is defined only between nld and nle
866	DO jj = nlcj+1, jpj ! added line(s) (inner only)
867	pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej)
868	pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej)
869	pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej)
870	END DO
871	DO ji = nlci+1, jpi ! added column(s) (full)
872	pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej)
873	pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj )
874	pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej)
875	END DO
876	!
877	ELSE ! standard close or cyclic treatment
878	!
879	! ! East-West boundaries
880	IF( nbondi == 2 .AND. & !* cyclic
881	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
882	pt2d( 1 ,:) = pt2d(jpim1,:) ! west
883	pt2d(jpi,:) = pt2d( 2 ,:) ! east
884	ELSE !* closed
885	IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point
886	pt2d(nlci-jpreci+1:jpi ,:) = zland ! north
887	ENDIF
888	! ! North-South boundaries
889	! !* cyclic
890	IF( nbondj == 2 .AND. jperio == 7 ) THEN
891	pt2d(:, 1 ) = pt2d(:,jpjm1)
892	pt2d(:, jpj) = pt2d(:, 2)
893	ELSE !* closed
894	IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point
895	pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north
896	ENDIF
897	ENDIF
898
899	! 2. East and west directions exchange
900	! ------------------------------------
901	! we play with the neigbours AND the row number because of the periodicity
902	!
903	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
904	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
905	iihom = nlci-nreci
906	DO jl = 1, jpreci
907	zt2ew(:,jl,1) = pt2d(jpreci+jl,:)
908	zt2we(:,jl,1) = pt2d(iihom +jl,:)
909	END DO
910	END SELECT
911	!
912	! ! Migrations
913	imigr = jpreci * jpj
914	!
915	SELECT CASE ( nbondi )
916	CASE ( -1 )
917	CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
918	CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
919	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
920	CASE ( 0 )
921	CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
922	CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
923	CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
924	CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
925	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
926	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
927	CASE ( 1 )
928	CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
929	CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
930	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
931	END SELECT
932	!
933	! ! Write Dirichlet lateral conditions
934	iihom = nlci - jpreci
935	!
936	SELECT CASE ( nbondi )
937	CASE ( -1 )
938	DO jl = 1, jpreci
939	pt2d(iihom+jl,:) = zt2ew(:,jl,2)
940	END DO
941	CASE ( 0 )
942	DO jl = 1, jpreci
943	pt2d(jl ,:) = zt2we(:,jl,2)
944	pt2d(iihom+jl,:) = zt2ew(:,jl,2)
945	END DO
946	CASE ( 1 )
947	DO jl = 1, jpreci
948	pt2d(jl ,:) = zt2we(:,jl,2)
949	END DO
950	END SELECT
951
952	! 3. North and south directions
953	! -----------------------------
954	! always closed : we play only with the neigbours
955	!
956	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
957	ijhom = nlcj-nrecj
958	DO jl = 1, jprecj
959	zt2sn(:,jl,1) = pt2d(:,ijhom +jl)
960	zt2ns(:,jl,1) = pt2d(:,jprecj+jl)
961	END DO
962	ENDIF
963	!
964	! ! Migrations
965	imigr = jprecj * jpi
966	!
967	SELECT CASE ( nbondj )
968	CASE ( -1 )
969	CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
970	CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
971	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
972	CASE ( 0 )
973	CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
974	CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
975	CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
976	CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
977	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
978	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
979	CASE ( 1 )
980	CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
981	CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
982	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
983	END SELECT
984	!
985	! ! Write Dirichlet lateral conditions
986	ijhom = nlcj - jprecj
987	!
988	SELECT CASE ( nbondj )
989	CASE ( -1 )
990	DO jl = 1, jprecj
991	pt2d(:,ijhom+jl) = zt2ns(:,jl,2)
992	END DO
993	CASE ( 0 )
994	DO jl = 1, jprecj
995	pt2d(:,jl ) = zt2sn(:,jl,2)
996	pt2d(:,ijhom+jl) = zt2ns(:,jl,2)
997	END DO
998	CASE ( 1 )
999	DO jl = 1, jprecj
1000	pt2d(:,jl ) = zt2sn(:,jl,2)
1001	END DO
1002	END SELECT
1003
1004	! 4. north fold treatment
1005	! -----------------------
1006	!
1007	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
1008	!
1009	SELECT CASE ( jpni )
1010	CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp
1011	CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.
1012	END SELECT
1013	!
1014	ENDIF
1015	!
1016	DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
1017	!
1018	END SUBROUTINE mpp_lnk_2d
1019
1020
1021	SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
1022	!!----------------------------------------------------------------------
1023	!! * routine mpp_lnk_3d_gather *
1024	!!
1025	!! ** Purpose : Message passing manadgement for two 3D arrays
1026	!!
1027	!! ** Method : Use mppsend and mpprecv function for passing mask
1028	!! between processors following neighboring subdomains.
1029	!! domain parameters
1030	!! nlci : first dimension of the local subdomain
1031	!! nlcj : second dimension of the local subdomain
1032	!! nbondi : mark for "east-west local boundary"
1033	!! nbondj : mark for "north-south local boundary"
1034	!! noea : number for local neighboring processors
1035	!! nowe : number for local neighboring processors
1036	!! noso : number for local neighboring processors
1037	!! nono : number for local neighboring processors
1038	!!
1039	!! ** Action : ptab1 and ptab2 with update value at its periphery
1040	!!
1041	!!----------------------------------------------------------------------
1042	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab1 ! 1st 3D array on which the boundary condition is applied
1043	CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 arrays
1044	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab2 ! 3nd 3D array on which the boundary condition is applied
1045	CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! nature of ptab2 arrays
1046	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary
1047	!
1048	INTEGER :: jl ! dummy loop indices
1049	INTEGER :: ipk ! 3rd dimension of the input array
1050	INTEGER :: imigr, iihom, ijhom ! temporary integers
1051	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1052	INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
1053	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north
1054	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east
1055	!!----------------------------------------------------------------------
1056	!
1057	ipk = SIZE( ptab1, 3 )
1058	!
1059	ALLOCATE( zt4ns(jpi,jprecj,ipk,2,2), zt4sn(jpi,jprecj,ipk,2,2) , &
1060	& zt4ew(jpj,jpreci,ipk,2,2), zt4we(jpj,jpreci,ipk,2,2) )
1061
1062	! 1. standard boundary treatment
1063	! ------------------------------
1064	! ! East-West boundaries
1065	! !* Cyclic
1066	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1067	ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
1068	ptab1(jpi,:,:) = ptab1( 2 ,:,:)
1069	ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
1070	ptab2(jpi,:,:) = ptab2( 2 ,:,:)
1071	ELSE !* closed
1072	IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0._wp ! south except at F-point
1073	IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0._wp
1074	ptab1(nlci-jpreci+1:jpi ,:,:) = 0._wp ! north
1075	ptab2(nlci-jpreci+1:jpi ,:,:) = 0._wp
1076	ENDIF
1077	! ! North-South boundaries
1078	! !* cyclic
1079	IF( nbondj == 2 .AND. jperio == 7 ) THEN
1080	ptab1(:, 1 ,:) = ptab1(:, jpjm1 , :)
1081	ptab1(:, jpj ,:) = ptab1(:, 2 , :)
1082	ptab2(:, 1 ,:) = ptab2(:, jpjm1 , :)
1083	ptab2(:, jpj ,:) = ptab2(:, 2 , :)
1084	ELSE
1085	! !* closed
1086	IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0._wp ! south except at F-point
1087	IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0._wp
1088	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0._wp ! north
1089	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0._wp
1090	ENDIF
1091
1092	! 2. East and west directions exchange
1093	! ------------------------------------
1094	! we play with the neigbours AND the row number because of the periodicity
1095	!
1096	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
1097	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
1098	iihom = nlci-nreci
1099	DO jl = 1, jpreci
1100	zt4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
1101	zt4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
1102	zt4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
1103	zt4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
1104	END DO
1105	END SELECT
1106	!
1107	! ! Migrations
1108	imigr = jpreci * jpj * ipk *2
1109	!
1110	SELECT CASE ( nbondi )
1111	CASE ( -1 )
1112	CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req1 )
1113	CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea )
1114	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1115	CASE ( 0 )
1116	CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1117	CALL mppsend( 2, zt4we(1,1,1,1,1), imigr, noea, ml_req2 )
1118	CALL mpprecv( 1, zt4ew(1,1,1,1,2), imigr, noea )
1119	CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe )
1120	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1121	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1122	CASE ( 1 )
1123	CALL mppsend( 1, zt4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1124	CALL mpprecv( 2, zt4we(1,1,1,1,2), imigr, nowe )
1125	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1126	END SELECT
1127	!
1128	! ! Write Dirichlet lateral conditions
1129	iihom = nlci - jpreci
1130	!
1131	SELECT CASE ( nbondi )
1132	CASE ( -1 )
1133	DO jl = 1, jpreci
1134	ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2)
1135	ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2)
1136	END DO
1137	CASE ( 0 )
1138	DO jl = 1, jpreci
1139	ptab1(jl ,:,:) = zt4we(:,jl,:,1,2)
1140	ptab1(iihom+jl,:,:) = zt4ew(:,jl,:,1,2)
1141	ptab2(jl ,:,:) = zt4we(:,jl,:,2,2)
1142	ptab2(iihom+jl,:,:) = zt4ew(:,jl,:,2,2)
1143	END DO
1144	CASE ( 1 )
1145	DO jl = 1, jpreci
1146	ptab1(jl ,:,:) = zt4we(:,jl,:,1,2)
1147	ptab2(jl ,:,:) = zt4we(:,jl,:,2,2)
1148	END DO
1149	END SELECT
1150
1151	! 3. North and south directions
1152	! -----------------------------
1153	! always closed : we play only with the neigbours
1154	!
1155	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
1156	ijhom = nlcj - nrecj
1157	DO jl = 1, jprecj
1158	zt4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
1159	zt4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
1160	zt4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
1161	zt4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
1162	END DO
1163	ENDIF
1164	!
1165	! ! Migrations
1166	imigr = jprecj * jpi * ipk * 2
1167	!
1168	SELECT CASE ( nbondj )
1169	CASE ( -1 )
1170	CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req1 )
1171	CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono )
1172	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1173	CASE ( 0 )
1174	CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1175	CALL mppsend( 4, zt4sn(1,1,1,1,1), imigr, nono, ml_req2 )
1176	CALL mpprecv( 3, zt4ns(1,1,1,1,2), imigr, nono )
1177	CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso )
1178	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1179	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1180	CASE ( 1 )
1181	CALL mppsend( 3, zt4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1182	CALL mpprecv( 4, zt4sn(1,1,1,1,2), imigr, noso )
1183	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1184	END SELECT
1185	!
1186	! ! Write Dirichlet lateral conditions
1187	ijhom = nlcj - jprecj
1188	!
1189	SELECT CASE ( nbondj )
1190	CASE ( -1 )
1191	DO jl = 1, jprecj
1192	ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2)
1193	ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2)
1194	END DO
1195	CASE ( 0 )
1196	DO jl = 1, jprecj
1197	ptab1(:,jl ,:) = zt4sn(:,jl,:,1,2)
1198	ptab1(:,ijhom+jl,:) = zt4ns(:,jl,:,1,2)
1199	ptab2(:,jl ,:) = zt4sn(:,jl,:,2,2)
1200	ptab2(:,ijhom+jl,:) = zt4ns(:,jl,:,2,2)
1201	END DO
1202	CASE ( 1 )
1203	DO jl = 1, jprecj
1204	ptab1(:,jl,:) = zt4sn(:,jl,:,1,2)
1205	ptab2(:,jl,:) = zt4sn(:,jl,:,2,2)
1206	END DO
1207	END SELECT
1208
1209	! 4. north fold treatment
1210	! -----------------------
1211	IF( npolj /= 0 ) THEN
1212	!
1213	SELECT CASE ( jpni )
1214	CASE ( 1 )
1215	CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs.
1216	CALL lbc_nfd ( ptab2, cd_type2, psgn )
1217	CASE DEFAULT
1218	CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs.
1219	CALL mpp_lbc_north (ptab2, cd_type2, psgn)
1220	END SELECT
1221	!
1222	ENDIF
1223	!
1224	DEALLOCATE( zt4ns, zt4sn, zt4ew, zt4we )
1225	!
1226	END SUBROUTINE mpp_lnk_3d_gather
1227
1228
1229	SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
1230	!!----------------------------------------------------------------------
1231	!! * routine mpp_lnk_2d_e *
1232	!!
1233	!! ** Purpose : Message passing manadgement for 2d array (with halo)
1234	!!
1235	!! ** Method : Use mppsend and mpprecv function for passing mask
1236	!! between processors following neighboring subdomains.
1237	!! domain parameters
1238	!! nlci : first dimension of the local subdomain
1239	!! nlcj : second dimension of the local subdomain
1240	!! jpri : number of rows for extra outer halo
1241	!! jprj : number of columns for extra outer halo
1242	!! nbondi : mark for "east-west local boundary"
1243	!! nbondj : mark for "north-south local boundary"
1244	!! noea : number for local neighboring processors
1245	!! nowe : number for local neighboring processors
1246	!! noso : number for local neighboring processors
1247	!! nono : number for local neighboring processors
1248	!!
1249	!!----------------------------------------------------------------------
1250	INTEGER , INTENT(in ) :: jpri
1251	INTEGER , INTENT(in ) :: jprj
1252	REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo
1253	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
1254	! ! = T , U , V , F , W and I points
1255	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the
1256	!! ! north boundary, = 1. otherwise
1257	INTEGER :: jl ! dummy loop indices
1258	INTEGER :: imigr, iihom, ijhom ! temporary integers
1259	INTEGER :: ipreci, iprecj ! temporary integers
1260	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1261	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
1262	!!
1263	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
1264	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
1265	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
1266	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
1267	!!----------------------------------------------------------------------
1268
1269	ipreci = jpreci + jpri ! take into account outer extra 2D overlap area
1270	iprecj = jprecj + jprj
1271
1272
1273	! 1. standard boundary treatment (CAUTION: the order matters Here !!!! )
1274	! ------------------------------
1275	! !== North-South boundaries
1276	! !* cyclic
1277	IF( nbondj == 2 .AND. jperio == 7 ) THEN
1278	pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1 )
1279	pt2d(:, jpj :jpj+jprj) = pt2d ( :, 2 :2+jprj)
1280	ELSE !* closed
1281	IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0._wp ! south except at F-point
1282	pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp ! north
1283	ENDIF
1284	! !== East-West boundaries
1285	! !* Cyclic east-west
1286	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1287	pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east
1288	pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west
1289	ELSE !* closed
1290	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point
1291	pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north
1292	ENDIF
1293	!
1294	! north fold treatment
1295	! --------------------
1296	IF( npolj /= 0 ) THEN
1297	!
1298	SELECT CASE ( jpni )
1299	CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
1300	CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )
1301	END SELECT
1302	!
1303	ENDIF
1304
1305	! 2. East and west directions exchange
1306	! ------------------------------------
1307	! we play with the neigbours AND the row number because of the periodicity
1308	!
1309	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
1310	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
1311	iihom = nlci-nreci-jpri
1312	DO jl = 1, ipreci
1313	r2dew(:,jl,1) = pt2d(jpreci+jl,:)
1314	r2dwe(:,jl,1) = pt2d(iihom +jl,:)
1315	END DO
1316	END SELECT
1317	!
1318	! ! Migrations
1319	imigr = ipreci * ( jpj + 2*jprj)
1320	!
1321	SELECT CASE ( nbondi )
1322	CASE ( -1 )
1323	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
1324	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
1325	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1326	CASE ( 0 )
1327	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
1328	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
1329	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
1330	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
1331	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1332	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1333	CASE ( 1 )
1334	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
1335	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
1336	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1337	END SELECT
1338	!
1339	! ! Write Dirichlet lateral conditions
1340	iihom = nlci - jpreci
1341	!
1342	SELECT CASE ( nbondi )
1343	CASE ( -1 )
1344	DO jl = 1, ipreci
1345	pt2d(iihom+jl,:) = r2dew(:,jl,2)
1346	END DO
1347	CASE ( 0 )
1348	DO jl = 1, ipreci
1349	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
1350	pt2d( iihom+jl,:) = r2dew(:,jl,2)
1351	END DO
1352	CASE ( 1 )
1353	DO jl = 1, ipreci
1354	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
1355	END DO
1356	END SELECT
1357
1358	! 3. North and south directions
1359	! -----------------------------
1360	! always closed : we play only with the neigbours
1361	!
1362	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
1363	ijhom = nlcj-nrecj-jprj
1364	DO jl = 1, iprecj
1365	r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
1366	r2dns(:,jl,1) = pt2d(:,jprecj+jl)
1367	END DO
1368	ENDIF
1369	!
1370	! ! Migrations
1371	imigr = iprecj * ( jpi + 2*jpri )
1372	!
1373	SELECT CASE ( nbondj )
1374	CASE ( -1 )
1375	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
1376	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
1377	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1378	CASE ( 0 )
1379	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
1380	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
1381	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
1382	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
1383	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1384	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1385	CASE ( 1 )
1386	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
1387	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
1388	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1389	END SELECT
1390	!
1391	! ! Write Dirichlet lateral conditions
1392	ijhom = nlcj - jprecj
1393	!
1394	SELECT CASE ( nbondj )
1395	CASE ( -1 )
1396	DO jl = 1, iprecj
1397	pt2d(:,ijhom+jl) = r2dns(:,jl,2)
1398	END DO
1399	CASE ( 0 )
1400	DO jl = 1, iprecj
1401	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
1402	pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
1403	END DO
1404	CASE ( 1 )
1405	DO jl = 1, iprecj
1406	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
1407	END DO
1408	END SELECT
1409	!
1410	END SUBROUTINE mpp_lnk_2d_e
1411
1412
1413	SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval )
1414	!!----------------------------------------------------------------------
1415	!! * routine mpp_lnk_sum_3d *
1416	!!
1417	!! ** Purpose : Message passing manadgement (sum the overlap region)
1418	!!
1419	!! ** Method : Use mppsend and mpprecv function for passing mask
1420	!! between processors following neighboring subdomains.
1421	!! domain parameters
1422	!! nlci : first dimension of the local subdomain
1423	!! nlcj : second dimension of the local subdomain
1424	!! nbondi : mark for "east-west local boundary"
1425	!! nbondj : mark for "north-south local boundary"
1426	!! noea : number for local neighboring processors
1427	!! nowe : number for local neighboring processors
1428	!! noso : number for local neighboring processors
1429	!! nono : number for local neighboring processors
1430	!!
1431	!! ** Action : ptab with update value at its periphery
1432	!!
1433	!!----------------------------------------------------------------------
1434	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
1435	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
1436	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary
1437	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
1438	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
1439	!
1440	INTEGER :: ji, jj, jk, jl ! dummy loop indices
1441	INTEGER :: imigr, iihom, ijhom ! temporary integers
1442	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1443	REAL(wp) :: zland
1444	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
1445	!
1446	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north
1447	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east
1448	!!----------------------------------------------------------------------
1449	!
1450	ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), &
1451	& zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) )
1452	!
1453	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
1454	ELSE ; zland = 0._wp ! zero by default
1455	ENDIF
1456
1457	! 1. standard boundary treatment
1458	! ------------------------------
1459	! 2. East and west directions exchange
1460	! ------------------------------------
1461	! we play with the neigbours AND the row number because of the periodicity
1462	!
1463	SELECT CASE ( nbondi ) ! Read lateral conditions
1464	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
1465	iihom = nlci-jpreci
1466	DO jl = 1, jpreci
1467	zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0._wp
1468	zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0._wp
1469	END DO
1470	END SELECT
1471	!
1472	! ! Migrations
1473	imigr = jpreci * jpj * jpk
1474	!
1475	SELECT CASE ( nbondi )
1476	CASE ( -1 )
1477	CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
1478	CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
1479	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1480	CASE ( 0 )
1481	CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
1482	CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
1483	CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
1484	CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
1485	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1486	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1487	CASE ( 1 )
1488	CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
1489	CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
1490	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1491	END SELECT
1492	!
1493	! ! Write lateral conditions
1494	iihom = nlci-nreci
1495	!
1496	SELECT CASE ( nbondi )
1497	CASE ( -1 )
1498	DO jl = 1, jpreci
1499	ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2)
1500	END DO
1501	CASE ( 0 )
1502	DO jl = 1, jpreci
1503	ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)
1504	ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2)
1505	END DO
1506	CASE ( 1 )
1507	DO jl = 1, jpreci
1508	ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2)
1509	END DO
1510	END SELECT
1511
1512	! 3. North and south directions
1513	! -----------------------------
1514	! always closed : we play only with the neigbours
1515	!
1516	IF( nbondj /= 2 ) THEN ! Read lateral conditions
1517	ijhom = nlcj-jprecj
1518	DO jl = 1, jprecj
1519	zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0._wp
1520	zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0._wp
1521	END DO
1522	ENDIF
1523	!
1524	! ! Migrations
1525	imigr = jprecj * jpi * jpk
1526	!
1527	SELECT CASE ( nbondj )
1528	CASE ( -1 )
1529	CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
1530	CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
1531	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1532	CASE ( 0 )
1533	CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
1534	CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
1535	CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
1536	CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
1537	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1538	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1539	CASE ( 1 )
1540	CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
1541	CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
1542	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1543	END SELECT
1544	!
1545	! ! Write lateral conditions
1546	ijhom = nlcj-nrecj
1547	!
1548	SELECT CASE ( nbondj )
1549	CASE ( -1 )
1550	DO jl = 1, jprecj
1551	ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2)
1552	END DO
1553	CASE ( 0 )
1554	DO jl = 1, jprecj
1555	ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2)
1556	ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2)
1557	END DO
1558	CASE ( 1 )
1559	DO jl = 1, jprecj
1560	ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2)
1561	END DO
1562	END SELECT
1563
1564	! 4. north fold treatment
1565	! -----------------------
1566	!
1567	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
1568	!
1569	SELECT CASE ( jpni )
1570	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
1571	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
1572	END SELECT
1573	!
1574	ENDIF
1575	!
1576	DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
1577	!
1578	END SUBROUTINE mpp_lnk_sum_3d
1579
1580
1581	SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval )
1582	!!----------------------------------------------------------------------
1583	!! * routine mpp_lnk_sum_2d *
1584	!!
1585	!! ** Purpose : Message passing manadgement for 2d array (sum the overlap region)
1586	!!
1587	!! ** Method : Use mppsend and mpprecv function for passing mask
1588	!! between processors following neighboring subdomains.
1589	!! domain parameters
1590	!! nlci : first dimension of the local subdomain
1591	!! nlcj : second dimension of the local subdomain
1592	!! nbondi : mark for "east-west local boundary"
1593	!! nbondj : mark for "north-south local boundary"
1594	!! noea : number for local neighboring processors
1595	!! nowe : number for local neighboring processors
1596	!! noso : number for local neighboring processors
1597	!! nono : number for local neighboring processors
1598	!!----------------------------------------------------------------------
1599	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
1600	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d array grid-points
1601	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary
1602	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
1603	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
1604	!!
1605	INTEGER :: ji, jj, jl ! dummy loop indices
1606	INTEGER :: imigr, iihom, ijhom ! temporary integers
1607	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1608	REAL(wp) :: zland
1609	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
1610	!
1611	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north
1612	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east
1613	!!----------------------------------------------------------------------
1614	!
1615	ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &
1616	& zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )
1617	!
1618	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
1619	ELSE ; zland = 0._wp ! zero by default
1620	ENDIF
1621
1622	! 1. standard boundary treatment
1623	! ------------------------------
1624	! 2. East and west directions exchange
1625	! ------------------------------------
1626	! we play with the neigbours AND the row number because of the periodicity
1627	!
1628	SELECT CASE ( nbondi ) ! Read lateral conditions
1629	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
1630	iihom = nlci - jpreci
1631	DO jl = 1, jpreci
1632	zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp
1633	zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp
1634	END DO
1635	END SELECT
1636	!
1637	! ! Migrations
1638	imigr = jpreci * jpj
1639	!
1640	SELECT CASE ( nbondi )
1641	CASE ( -1 )
1642	CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
1643	CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
1644	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1645	CASE ( 0 )
1646	CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
1647	CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
1648	CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
1649	CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
1650	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1651	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1652	CASE ( 1 )
1653	CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
1654	CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
1655	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1656	END SELECT
1657	!
1658	! ! Write lateral conditions
1659	iihom = nlci-nreci
1660	!
1661	SELECT CASE ( nbondi )
1662	CASE ( -1 )
1663	DO jl = 1, jpreci
1664	pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2)
1665	END DO
1666	CASE ( 0 )
1667	DO jl = 1, jpreci
1668	pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)
1669	pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2)
1670	END DO
1671	CASE ( 1 )
1672	DO jl = 1, jpreci
1673	pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2)
1674	END DO
1675	END SELECT
1676
1677
1678	! 3. North and south directions
1679	! -----------------------------
1680	! always closed : we play only with the neigbours
1681	!
1682	IF( nbondj /= 2 ) THEN ! Read lateral conditions
1683	ijhom = nlcj - jprecj
1684	DO jl = 1, jprecj
1685	zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp
1686	zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp
1687	END DO
1688	ENDIF
1689	!
1690	! ! Migrations
1691	imigr = jprecj * jpi
1692	!
1693	SELECT CASE ( nbondj )
1694	CASE ( -1 )
1695	CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
1696	CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
1697	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1698	CASE ( 0 )
1699	CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
1700	CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
1701	CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
1702	CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
1703	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1704	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1705	CASE ( 1 )
1706	CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
1707	CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
1708	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1709	END SELECT
1710	!
1711	! ! Write lateral conditions
1712	ijhom = nlcj-nrecj
1713	!
1714	SELECT CASE ( nbondj )
1715	CASE ( -1 )
1716	DO jl = 1, jprecj
1717	pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2)
1718	END DO
1719	CASE ( 0 )
1720	DO jl = 1, jprecj
1721	pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)
1722	pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2)
1723	END DO
1724	CASE ( 1 )
1725	DO jl = 1, jprecj
1726	pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2)
1727	END DO
1728	END SELECT
1729
1730	! 4. north fold treatment
1731	! -----------------------
1732	!
1733	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
1734	!
1735	SELECT CASE ( jpni )
1736	CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp
1737	CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.
1738	END SELECT
1739	!
1740	ENDIF
1741	!
1742	DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
1743	!
1744	END SUBROUTINE mpp_lnk_sum_2d
1745
1746
1747	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1748	!!----------------------------------------------------------------------
1749	!! * routine mppsend *
1750	!!
1751	!! ** Purpose : Send messag passing array
1752	!!
1753	!!----------------------------------------------------------------------
1754	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1755	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
1756	INTEGER , INTENT(in ) :: kdest ! receive process number
1757	INTEGER , INTENT(in ) :: ktyp ! tag of the message
1758	INTEGER , INTENT(in ) :: md_req ! argument for isend
1759	!!
1760	INTEGER :: iflag
1761	!!----------------------------------------------------------------------
1762	!
1763	SELECT CASE ( cn_mpi_send )
1764	CASE ( 'S' ) ! Standard mpi send (blocking)
1765	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
1766	CASE ( 'B' ) ! Buffer mpi send (blocking)
1767	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
1768	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
1769	! be carefull, one more argument here : the mpi request identifier..
1770	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1771	END SELECT
1772	!
1773	END SUBROUTINE mppsend
1774
1775
1776	SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
1777	!!----------------------------------------------------------------------
1778	!! * routine mpprecv *
1779	!!
1780	!! ** Purpose : Receive messag passing array
1781	!!
1782	!!----------------------------------------------------------------------
1783	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1784	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
1785	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
1786	INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
1787	!!
1788	INTEGER :: istatus(mpi_status_size)
1789	INTEGER :: iflag
1790	INTEGER :: use_source
1791	!!----------------------------------------------------------------------
1792	!
1793	! If a specific process number has been passed to the receive call,
1794	! use that one. Default is to use mpi_any_source
1795	use_source = mpi_any_source
1796	IF( PRESENT(ksource) ) use_source = ksource
1797	!
1798	CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag )
1799	!
1800	END SUBROUTINE mpprecv
1801
1802
1803	SUBROUTINE mppgather( ptab, kp, pio )
1804	!!----------------------------------------------------------------------
1805	!! * routine mppgather *
1806	!!
1807	!! ** Purpose : Transfert between a local subdomain array and a work
1808	!! array which is distributed following the vertical level.
1809	!!
1810	!!----------------------------------------------------------------------
1811	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array
1812	INTEGER , INTENT(in ) :: kp ! record length
1813	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
1814	!!
1815	INTEGER :: itaille, ierror ! temporary integer
1816	!!---------------------------------------------------------------------
1817	!
1818	itaille = jpi * jpj
1819	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
1820	& mpi_double_precision, kp , mpi_comm_opa, ierror )
1821	!
1822	END SUBROUTINE mppgather
1823
1824
1825	SUBROUTINE mppscatter( pio, kp, ptab )
1826	!!----------------------------------------------------------------------
1827	!! * routine mppscatter *
1828	!!
1829	!! ** Purpose : Transfert between awork array which is distributed
1830	!! following the vertical level and the local subdomain array.
1831	!!
1832	!!----------------------------------------------------------------------
1833	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
1834	INTEGER :: kp ! Tag (not used with MPI
1835	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
1836	!!
1837	INTEGER :: itaille, ierror ! temporary integer
1838	!!---------------------------------------------------------------------
1839	!
1840	itaille = jpi * jpj
1841	!
1842	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
1843	& mpi_double_precision, kp , mpi_comm_opa, ierror )
1844	!
1845	END SUBROUTINE mppscatter
1846
1847
1848	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1849	!!----------------------------------------------------------------------
1850	!! * routine mppmax_a_int *
1851	!!
1852	!! ** Purpose : Find maximum value in an integer layout array
1853	!!
1854	!!----------------------------------------------------------------------
1855	INTEGER , INTENT(in ) :: kdim ! size of array
1856	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1857	INTEGER , INTENT(in ), OPTIONAL :: kcom !
1858	!
1859	INTEGER :: ierror, localcomm ! temporary integer
1860	INTEGER, DIMENSION(kdim) :: iwork
1861	!!----------------------------------------------------------------------
1862	!
1863	localcomm = mpi_comm_opa
1864	IF( PRESENT(kcom) ) localcomm = kcom
1865	!
1866	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1867	!
1868	ktab(:) = iwork(:)
1869	!
1870	END SUBROUTINE mppmax_a_int
1871
1872
1873	SUBROUTINE mppmax_int( ktab, kcom )
1874	!!----------------------------------------------------------------------
1875	!! * routine mppmax_int *
1876	!!
1877	!! ** Purpose : Find maximum value in an integer layout array
1878	!!
1879	!!----------------------------------------------------------------------
1880	INTEGER, INTENT(inout) :: ktab ! ???
1881	INTEGER, INTENT(in ), OPTIONAL :: kcom ! ???
1882	!
1883	INTEGER :: ierror, iwork, localcomm ! temporary integer
1884	!!----------------------------------------------------------------------
1885	!
1886	localcomm = mpi_comm_opa
1887	IF( PRESENT(kcom) ) localcomm = kcom
1888	!
1889	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror )
1890	!
1891	ktab = iwork
1892	!
1893	END SUBROUTINE mppmax_int
1894
1895
1896	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1897	!!----------------------------------------------------------------------
1898	!! * routine mppmin_a_int *
1899	!!
1900	!! ** Purpose : Find minimum value in an integer layout array
1901	!!
1902	!!----------------------------------------------------------------------
1903	INTEGER , INTENT( in ) :: kdim ! size of array
1904	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1905	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
1906	!!
1907	INTEGER :: ierror, localcomm ! temporary integer
1908	INTEGER, DIMENSION(kdim) :: iwork
1909	!!----------------------------------------------------------------------
1910	!
1911	localcomm = mpi_comm_opa
1912	IF( PRESENT(kcom) ) localcomm = kcom
1913	!
1914	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1915	!
1916	ktab(:) = iwork(:)
1917	!
1918	END SUBROUTINE mppmin_a_int
1919
1920
1921	SUBROUTINE mppmin_int( ktab, kcom )
1922	!!----------------------------------------------------------------------
1923	!! * routine mppmin_int *
1924	!!
1925	!! ** Purpose : Find minimum value in an integer layout array
1926	!!
1927	!!----------------------------------------------------------------------
1928	INTEGER, INTENT(inout) :: ktab ! ???
1929	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
1930	!!
1931	INTEGER :: ierror, iwork, localcomm
1932	!!----------------------------------------------------------------------
1933	!
1934	localcomm = mpi_comm_opa
1935	IF( PRESENT(kcom) ) localcomm = kcom
1936	!
1937	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1938	!
1939	ktab = iwork
1940	!
1941	END SUBROUTINE mppmin_int
1942
1943
1944	SUBROUTINE mppsum_a_int( ktab, kdim )
1945	!!----------------------------------------------------------------------
1946	!! * routine mppsum_a_int *
1947	!!
1948	!! ** Purpose : Global integer sum, 1D array case
1949	!!
1950	!!----------------------------------------------------------------------
1951	INTEGER, INTENT(in ) :: kdim ! ???
1952	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
1953	!
1954	INTEGER :: ierror
1955	INTEGER, DIMENSION (kdim) :: iwork
1956	!!----------------------------------------------------------------------
1957	!
1958	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1959	!
1960	ktab(:) = iwork(:)
1961	!
1962	END SUBROUTINE mppsum_a_int
1963
1964
1965	SUBROUTINE mppsum_int( ktab )
1966	!!----------------------------------------------------------------------
1967	!! * routine mppsum_int *
1968	!!
1969	!! ** Purpose : Global integer sum
1970	!!
1971	!!----------------------------------------------------------------------
1972	INTEGER, INTENT(inout) :: ktab
1973	!!
1974	INTEGER :: ierror, iwork
1975	!!----------------------------------------------------------------------
1976	!
1977	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1978	!
1979	ktab = iwork
1980	!
1981	END SUBROUTINE mppsum_int
1982
1983
1984	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1985	!!----------------------------------------------------------------------
1986	!! * routine mppmax_a_real *
1987	!!
1988	!! ** Purpose : Maximum of a 1D array
1989	!!
1990	!!----------------------------------------------------------------------
1991	REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab
1992	INTEGER , INTENT(in ) :: kdim
1993	INTEGER , OPTIONAL , INTENT(in ) :: kcom
1994	!
1995	INTEGER :: ierror, localcomm
1996	REAL(wp), DIMENSION(kdim) :: zwork
1997	!!----------------------------------------------------------------------
1998	!
1999	localcomm = mpi_comm_opa
2000	IF( PRESENT(kcom) ) localcomm = kcom
2001	!
2002	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
2003	ptab(:) = zwork(:)
2004	!
2005	END SUBROUTINE mppmax_a_real
2006
2007
2008	SUBROUTINE mppmax_real( ptab, kcom )
2009	!!----------------------------------------------------------------------
2010	!! * routine mppmax_real *
2011	!!
2012	!! ** Purpose : Maximum for each element of a 1D array
2013	!!
2014	!!----------------------------------------------------------------------
2015	REAL(wp), INTENT(inout) :: ptab ! ???
2016	INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???
2017	!!
2018	INTEGER :: ierror, localcomm
2019	REAL(wp) :: zwork
2020	!!----------------------------------------------------------------------
2021	!
2022	localcomm = mpi_comm_opa
2023	IF( PRESENT(kcom) ) localcomm = kcom
2024	!
2025	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
2026	ptab = zwork
2027	!
2028	END SUBROUTINE mppmax_real
2029
2030
2031	SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom )
2032	!!----------------------------------------------------------------------
2033	!! * routine mppmax_real *
2034	!!
2035	!! ** Purpose : Maximum
2036	!!
2037	!!----------------------------------------------------------------------
2038	REAL(wp), DIMENSION(kdim), INTENT(inout) :: pt1d ! 1D arrays
2039	INTEGER , INTENT(in ) :: kdim
2040	INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator
2041	!!
2042	INTEGER :: ierror, localcomm
2043	REAL(wp), DIMENSION(kdim) :: zwork
2044	!!----------------------------------------------------------------------
2045	!
2046	localcomm = mpi_comm_opa
2047	IF( PRESENT(kcom) ) localcomm = kcom
2048	!
2049	CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
2050	pt1d(:) = zwork(:)
2051	!
2052	END SUBROUTINE mppmax_real_multiple
2053
2054
2055	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
2056	!!----------------------------------------------------------------------
2057	!! * routine mppmin_a_real *
2058	!!
2059	!! ** Purpose : Minimum of REAL, array case
2060	!!
2061	!!-----------------------------------------------------------------------
2062	INTEGER , INTENT(in ) :: kdim
2063	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
2064	INTEGER , INTENT(in ), OPTIONAL :: kcom
2065	!!
2066	INTEGER :: ierror, localcomm
2067	REAL(wp), DIMENSION(kdim) :: zwork
2068	!!-----------------------------------------------------------------------
2069	!
2070	localcomm = mpi_comm_opa
2071	IF( PRESENT(kcom) ) localcomm = kcom
2072	!
2073	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
2074	ptab(:) = zwork(:)
2075	!
2076	END SUBROUTINE mppmin_a_real
2077
2078
2079	SUBROUTINE mppmin_real( ptab, kcom )
2080	!!----------------------------------------------------------------------
2081	!! * routine mppmin_real *
2082	!!
2083	!! ** Purpose : minimum of REAL, scalar case
2084	!!
2085	!!-----------------------------------------------------------------------
2086	REAL(wp), INTENT(inout) :: ptab !
2087	INTEGER , INTENT(in ), OPTIONAL :: kcom
2088	!!
2089	INTEGER :: ierror
2090	REAL(wp) :: zwork
2091	INTEGER :: localcomm
2092	!!-----------------------------------------------------------------------
2093	!
2094	localcomm = mpi_comm_opa
2095	IF( PRESENT(kcom) ) localcomm = kcom
2096	!
2097	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
2098	ptab = zwork
2099	!
2100	END SUBROUTINE mppmin_real
2101
2102
2103	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
2104	!!----------------------------------------------------------------------
2105	!! * routine mppsum_a_real *
2106	!!
2107	!! ** Purpose : global sum, REAL ARRAY argument case
2108	!!
2109	!!-----------------------------------------------------------------------
2110	INTEGER , INTENT( in ) :: kdim ! size of ptab
2111	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
2112	INTEGER , INTENT( in ), OPTIONAL :: kcom
2113	!!
2114	INTEGER :: ierror ! temporary integer
2115	INTEGER :: localcomm
2116	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
2117	!!-----------------------------------------------------------------------
2118	!
2119	localcomm = mpi_comm_opa
2120	IF( PRESENT(kcom) ) localcomm = kcom
2121	!
2122	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
2123	ptab(:) = zwork(:)
2124	!
2125	END SUBROUTINE mppsum_a_real
2126
2127
2128	SUBROUTINE mppsum_real( ptab, kcom )
2129	!!----------------------------------------------------------------------
2130	!! * routine mppsum_real *
2131	!!
2132	!! ** Purpose : global sum, SCALAR argument case
2133	!!
2134	!!-----------------------------------------------------------------------
2135	REAL(wp), INTENT(inout) :: ptab ! input scalar
2136	INTEGER , INTENT(in ), OPTIONAL :: kcom
2137	!!
2138	INTEGER :: ierror, localcomm
2139	REAL(wp) :: zwork
2140	!!-----------------------------------------------------------------------
2141	!
2142	localcomm = mpi_comm_opa
2143	IF( PRESENT(kcom) ) localcomm = kcom
2144	!
2145	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
2146	ptab = zwork
2147	!
2148	END SUBROUTINE mppsum_real
2149
2150
2151	SUBROUTINE mppsum_realdd( ytab, kcom )
2152	!!----------------------------------------------------------------------
2153	!! * routine mppsum_realdd *
2154	!!
2155	!! ** Purpose : global sum in Massively Parallel Processing
2156	!! SCALAR argument case for double-double precision
2157	!!
2158	!!-----------------------------------------------------------------------
2159	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
2160	INTEGER , INTENT(in ), OPTIONAL :: kcom
2161	!
2162	INTEGER :: ierror
2163	INTEGER :: localcomm
2164	COMPLEX(wp) :: zwork
2165	!!-----------------------------------------------------------------------
2166	!
2167	localcomm = mpi_comm_opa
2168	IF( PRESENT(kcom) ) localcomm = kcom
2169	!
2170	! reduce local sums into global sum
2171	CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )
2172	ytab = zwork
2173	!
2174	END SUBROUTINE mppsum_realdd
2175
2176
2177	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
2178	!!----------------------------------------------------------------------
2179	!! * routine mppsum_a_realdd *
2180	!!
2181	!! ** Purpose : global sum in Massively Parallel Processing
2182	!! COMPLEX ARRAY case for double-double precision
2183	!!
2184	!!-----------------------------------------------------------------------
2185	INTEGER , INTENT(in ) :: kdim ! size of ytab
2186	COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array
2187	INTEGER , OPTIONAL , INTENT(in ) :: kcom
2188	!
2189	INTEGER:: ierror, localcomm ! local integer
2190	COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace
2191	!!-----------------------------------------------------------------------
2192	!
2193	localcomm = mpi_comm_opa
2194	IF( PRESENT(kcom) ) localcomm = kcom
2195	!
2196	CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror )
2197	ytab(:) = zwork(:)
2198	!
2199	END SUBROUTINE mppsum_a_realdd
2200
2201
2202	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
2203	!!------------------------------------------------------------------------
2204	!! * routine mpp_minloc *
2205	!!
2206	!! ** Purpose : Compute the global minimum of an array ptab
2207	!! and also give its global position
2208	!!
2209	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2210	!!
2211	!!--------------------------------------------------------------------------
2212	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
2213	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
2214	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
2215	INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame
2216	!
2217	INTEGER :: ierror
2218	INTEGER , DIMENSION(2) :: ilocs
2219	REAL(wp) :: zmin ! local minimum
2220	REAL(wp), DIMENSION(2,1) :: zain, zaout
2221	!!-----------------------------------------------------------------------
2222	!
2223	zmin = MINVAL( ptab(:,:) , mask= pmask == 1._wp )
2224	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp )
2225	!
2226	ki = ilocs(1) + nimpp - 1
2227	kj = ilocs(2) + njmpp - 1
2228	!
2229	zain(1,:)=zmin
2230	zain(2,:)=ki+10000.*kj
2231	!
2232	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
2233	!
2234	pmin = zaout(1,1)
2235	kj = INT(zaout(2,1)/10000.)
2236	ki = INT(zaout(2,1) - 10000.*kj )
2237	!
2238	END SUBROUTINE mpp_minloc2d
2239
2240
2241	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
2242	!!------------------------------------------------------------------------
2243	!! * routine mpp_minloc *
2244	!!
2245	!! ** Purpose : Compute the global minimum of an array ptab
2246	!! and also give its global position
2247	!!
2248	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2249	!!
2250	!!--------------------------------------------------------------------------
2251	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! Local 2D array
2252	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! Local mask
2253	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
2254	INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame
2255	!
2256	INTEGER :: ierror
2257	REAL(wp) :: zmin ! local minimum
2258	INTEGER , DIMENSION(3) :: ilocs
2259	REAL(wp), DIMENSION(2,1) :: zain, zaout
2260	!!-----------------------------------------------------------------------
2261	!
2262	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp )
2263	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp )
2264	!
2265	ki = ilocs(1) + nimpp - 1
2266	kj = ilocs(2) + njmpp - 1
2267	kk = ilocs(3)
2268	!
2269	zain(1,:) = zmin
2270	zain(2,:) = ki + 10000.kj + 100000000.kk
2271	!
2272	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
2273	!
2274	pmin = zaout(1,1)
2275	kk = INT( zaout(2,1) / 100000000. )
2276	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
2277	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2278	!
2279	END SUBROUTINE mpp_minloc3d
2280
2281
2282	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2283	!!------------------------------------------------------------------------
2284	!! * routine mpp_maxloc *
2285	!!
2286	!! ** Purpose : Compute the global maximum of an array ptab
2287	!! and also give its global position
2288	!!
2289	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2290	!!
2291	!!--------------------------------------------------------------------------
2292	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
2293	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
2294	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
2295	INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame
2296	!!
2297	INTEGER :: ierror
2298	INTEGER, DIMENSION (2) :: ilocs
2299	REAL(wp) :: zmax ! local maximum
2300	REAL(wp), DIMENSION(2,1) :: zain, zaout
2301	!!-----------------------------------------------------------------------
2302	!
2303	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1._wp )
2304	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp )
2305	!
2306	ki = ilocs(1) + nimpp - 1
2307	kj = ilocs(2) + njmpp - 1
2308	!
2309	zain(1,:) = zmax
2310	zain(2,:) = ki + 10000. * kj
2311	!
2312	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2313	!
2314	pmax = zaout(1,1)
2315	kj = INT( zaout(2,1) / 10000. )
2316	ki = INT( zaout(2,1) - 10000.* kj )
2317	!
2318	END SUBROUTINE mpp_maxloc2d
2319
2320
2321	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2322	!!------------------------------------------------------------------------
2323	!! * routine mpp_maxloc *
2324	!!
2325	!! ** Purpose : Compute the global maximum of an array ptab
2326	!! and also give its global position
2327	!!
2328	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2329	!!
2330	!!--------------------------------------------------------------------------
2331	REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: ptab ! Local 2D array
2332	REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pmask ! Local mask
2333	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
2334	INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame
2335	!
2336	INTEGER :: ierror ! local integer
2337	REAL(wp) :: zmax ! local maximum
2338	REAL(wp), DIMENSION(2,1) :: zain, zaout
2339	INTEGER , DIMENSION(3) :: ilocs
2340	!!-----------------------------------------------------------------------
2341	!
2342	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp )
2343	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp )
2344	!
2345	ki = ilocs(1) + nimpp - 1
2346	kj = ilocs(2) + njmpp - 1
2347	kk = ilocs(3)
2348	!
2349	zain(1,:) = zmax
2350	zain(2,:) = ki + 10000.kj + 100000000.kk
2351	!
2352	CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, MPI_COMM_OPA, ierror )
2353	!
2354	pmax = zaout(1,1)
2355	kk = INT( zaout(2,1) / 100000000. )
2356	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
2357	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2358	!
2359	END SUBROUTINE mpp_maxloc3d
2360
2361
2362	SUBROUTINE mppsync()
2363	!!----------------------------------------------------------------------
2364	!! * routine mppsync *
2365	!!
2366	!! ** Purpose : Massively parallel processors, synchroneous
2367	!!
2368	!!-----------------------------------------------------------------------
2369	INTEGER :: ierror
2370	!!-----------------------------------------------------------------------
2371	!
2372	CALL mpi_barrier( mpi_comm_opa, ierror )
2373	!
2374	END SUBROUTINE mppsync
2375
2376
2377	SUBROUTINE mppstop
2378	!!----------------------------------------------------------------------
2379	!! * routine mppstop *
2380	!!
2381	!! ** purpose : Stop massively parallel processors method
2382	!!
2383	!!----------------------------------------------------------------------
2384	INTEGER :: info
2385	!!----------------------------------------------------------------------
2386	!
2387	CALL mppsync
2388	CALL mpi_finalize( info )
2389	!
2390	END SUBROUTINE mppstop
2391
2392
2393	SUBROUTINE mpp_comm_free( kcom )
2394	!!----------------------------------------------------------------------
2395	INTEGER, INTENT(in) :: kcom
2396	!!
2397	INTEGER :: ierr
2398	!!----------------------------------------------------------------------
2399	!
2400	CALL MPI_COMM_FREE(kcom, ierr)
2401	!
2402	END SUBROUTINE mpp_comm_free
2403
2404
2405	SUBROUTINE mpp_ini_ice( pindic, kumout )
2406	!!----------------------------------------------------------------------
2407	!! * routine mpp_ini_ice *
2408	!!
2409	!! ** Purpose : Initialize special communicator for ice areas
2410	!! condition together with global variables needed in the ddmpp folding
2411	!!
2412	!! ** Method : - Look for ice processors in ice routines
2413	!! - Put their number in nrank_ice
2414	!! - Create groups for the world processors and the ice processors
2415	!! - Create a communicator for ice processors
2416	!!
2417	!! ** output
2418	!! njmppmax = njmpp for northern procs
2419	!! ndim_rank_ice = number of processors with ice
2420	!! nrank_ice (ndim_rank_ice) = ice processors
2421	!! ngrp_iworld = group ID for the world processors
2422	!! ngrp_ice = group ID for the ice processors
2423	!! ncomm_ice = communicator for the ice procs.
2424	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
2425	!!
2426	!!----------------------------------------------------------------------
2427	INTEGER, INTENT(in) :: pindic
2428	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
2429	!!
2430	INTEGER :: jjproc
2431	INTEGER :: ii, ierr
2432	INTEGER, ALLOCATABLE, DIMENSION(:) :: kice
2433	INTEGER, ALLOCATABLE, DIMENSION(:) :: zwork
2434	!!----------------------------------------------------------------------
2435	!
2436	! Since this is just an init routine and these arrays are of length jpnij
2437	! then don't use wrk_nemo module - just allocate and deallocate.
2438	ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
2439	IF( ierr /= 0 ) THEN
2440	WRITE(kumout, cform_err)
2441	WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
2442	CALL mppstop
2443	ENDIF
2444
2445	! Look for how many procs with sea-ice
2446	!
2447	kice = 0
2448	DO jjproc = 1, jpnij
2449	IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1
2450	END DO
2451	!
2452	zwork = 0
2453	CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
2454	ndim_rank_ice = SUM( zwork )
2455
2456	! Allocate the right size to nrank_north
2457	IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice )
2458	ALLOCATE( nrank_ice(ndim_rank_ice) )
2459	!
2460	ii = 0
2461	nrank_ice = 0
2462	DO jjproc = 1, jpnij
2463	IF( zwork(jjproc) == 1) THEN
2464	ii = ii + 1
2465	nrank_ice(ii) = jjproc -1
2466	ENDIF
2467	END DO
2468
2469	! Create the world group
2470	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
2471
2472	! Create the ice group from the world group
2473	CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2474
2475	! Create the ice communicator , ie the pool of procs with sea-ice
2476	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2477
2478	! Find proc number in the world of proc 0 in the north
2479	! The following line seems to be useless, we just comment & keep it as reminder
2480	! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
2481	!
2482	CALL MPI_GROUP_FREE(ngrp_ice, ierr)
2483	CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
2484
2485	DEALLOCATE(kice, zwork)
2486	!
2487	END SUBROUTINE mpp_ini_ice
2488
2489
2490	SUBROUTINE mpp_ini_znl( kumout )
2491	!!----------------------------------------------------------------------
2492	!! * routine mpp_ini_znl *
2493	!!
2494	!! ** Purpose : Initialize special communicator for computing zonal sum
2495	!!
2496	!! ** Method : - Look for processors in the same row
2497	!! - Put their number in nrank_znl
2498	!! - Create group for the znl processors
2499	!! - Create a communicator for znl processors
2500	!! - Determine if processor should write znl files
2501	!!
2502	!! ** output
2503	!! ndim_rank_znl = number of processors on the same row
2504	!! ngrp_znl = group ID for the znl processors
2505	!! ncomm_znl = communicator for the ice procs.
2506	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
2507	!!
2508	!!----------------------------------------------------------------------
2509	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
2510	!
2511	INTEGER :: jproc ! dummy loop integer
2512	INTEGER :: ierr, ii ! local integer
2513	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
2514	!!----------------------------------------------------------------------
2515	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
2516	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2517	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa : ', mpi_comm_opa
2518	!
2519	ALLOCATE( kwork(jpnij), STAT=ierr )
2520	IF( ierr /= 0 ) THEN
2521	WRITE(kumout, cform_err)
2522	WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2523	CALL mppstop
2524	ENDIF
2525
2526	IF( jpnj == 1 ) THEN
2527	ngrp_znl = ngrp_world
2528	ncomm_znl = mpi_comm_opa
2529	ELSE
2530	!
2531	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2532	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2533	!-$$ CALL flush(numout)
2534	!
2535	! Count number of processors on the same row
2536	ndim_rank_znl = 0
2537	DO jproc=1,jpnij
2538	IF ( kwork(jproc) == njmpp ) THEN
2539	ndim_rank_znl = ndim_rank_znl + 1
2540	ENDIF
2541	END DO
2542	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2543	!-$$ CALL flush(numout)
2544	! Allocate the right size to nrank_znl
2545	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2546	ALLOCATE(nrank_znl(ndim_rank_znl))
2547	ii = 0
2548	nrank_znl (:) = 0
2549	DO jproc=1,jpnij
2550	IF ( kwork(jproc) == njmpp) THEN
2551	ii = ii + 1
2552	nrank_znl(ii) = jproc -1
2553	ENDIF
2554	END DO
2555	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2556	!-$$ CALL flush(numout)
2557
2558	! Create the opa group
2559	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2560	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2561	!-$$ CALL flush(numout)
2562
2563	! Create the znl group from the opa group
2564	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2565	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2566	!-$$ CALL flush(numout)
2567
2568	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2569	CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2570	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2571	!-$$ CALL flush(numout)
2572	!
2573	END IF
2574
2575	! Determines if processor if the first (starting from i=1) on the row
2576	IF ( jpni == 1 ) THEN
2577	l_znl_root = .TRUE.
2578	ELSE
2579	l_znl_root = .FALSE.
2580	kwork (1) = nimpp
2581	CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2582	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2583	END IF
2584
2585	DEALLOCATE(kwork)
2586
2587	END SUBROUTINE mpp_ini_znl
2588
2589
2590	SUBROUTINE mpp_ini_north
2591	!!----------------------------------------------------------------------
2592	!! * routine mpp_ini_north *
2593	!!
2594	!! ** Purpose : Initialize special communicator for north folding
2595	!! condition together with global variables needed in the mpp folding
2596	!!
2597	!! ** Method : - Look for northern processors
2598	!! - Put their number in nrank_north
2599	!! - Create groups for the world processors and the north processors
2600	!! - Create a communicator for northern processors
2601	!!
2602	!! ** output
2603	!! njmppmax = njmpp for northern procs
2604	!! ndim_rank_north = number of processors in the northern line
2605	!! nrank_north (ndim_rank_north) = number of the northern procs.
2606	!! ngrp_world = group ID for the world processors
2607	!! ngrp_north = group ID for the northern processors
2608	!! ncomm_north = communicator for the northern procs.
2609	!! north_root = number (in the world) of proc 0 in the northern comm.
2610	!!
2611	!!----------------------------------------------------------------------
2612	INTEGER :: ierr
2613	INTEGER :: jjproc
2614	INTEGER :: ii, ji
2615	!!----------------------------------------------------------------------
2616	!
2617	njmppmax = MAXVAL( njmppt )
2618	!
2619	! Look for how many procs on the northern boundary
2620	ndim_rank_north = 0
2621	DO jjproc = 1, jpnij
2622	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
2623	END DO
2624	!
2625	! Allocate the right size to nrank_north
2626	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2627	ALLOCATE( nrank_north(ndim_rank_north) )
2628
2629	! Fill the nrank_north array with proc. number of northern procs.
2630	! Note : the rank start at 0 in MPI
2631	ii = 0
2632	DO ji = 1, jpnij
2633	IF ( njmppt(ji) == njmppmax ) THEN
2634	ii=ii+1
2635	nrank_north(ii)=ji-1
2636	END IF
2637	END DO
2638	!
2639	! create the world group
2640	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2641	!
2642	! Create the North group from the world group
2643	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2644	!
2645	! Create the North communicator , ie the pool of procs in the north group
2646	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2647	!
2648	END SUBROUTINE mpp_ini_north
2649
2650
2651	SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2652	!!---------------------------------------------------------------------
2653	!! * routine mpp_lbc_north_3d *
2654	!!
2655	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2656	!! in mpp configuration in case of jpn1 > 1
2657	!!
2658	!! ** Method : North fold condition and mpp with more than one proc
2659	!! in i-direction require a specific treatment. We gather
2660	!! the 4 northern lines of the global domain on 1 processor
2661	!! and apply lbc north-fold on this sub array. Then we
2662	!! scatter the north fold array back to the processors.
2663	!!----------------------------------------------------------------------
2664	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied
2665	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
2666	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold
2667	!
2668	INTEGER :: ji, jj, jr, jk
2669	INTEGER :: ipk ! 3rd dimension of the input array
2670	INTEGER :: ierr, itaille, ildi, ilei, iilb
2671	INTEGER :: ijpj, ijpjm1, ij, iproc
2672	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather
2673	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
2674	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather
2675	! ! Workspace for message transfers avoiding mpi_allgather
2676	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab
2677	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk
2678	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
2679	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr
2680
2681	INTEGER :: istatus(mpi_status_size)
2682	INTEGER :: iflag
2683	!!----------------------------------------------------------------------
2684	!
2685	ipk = SIZE( pt3d, 3 )
2686	!
2687	ALLOCATE( ztab (jpiglo,4,ipk), znorthloc(jpi,4,ipk), zfoldwk(jpi,4,ipk), znorthgloio(jpi,4,ipk,jpni) )
2688	ALLOCATE( ztabl(jpi ,4,ipk), ztabr(jpi*jpmaxngh,4,ipk) )
2689
2690	ijpj = 4
2691	ijpjm1 = 3
2692	!
2693	znorthloc(:,:,:) = 0._wp
2694	DO jk = 1, ipk
2695	DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d
2696	ij = jj - nlcj + ijpj
2697	znorthloc(:,ij,jk) = pt3d(:,jj,jk)
2698	END DO
2699	END DO
2700	!
2701	! ! Build in procs of ncomm_north the znorthgloio
2702	itaille = jpi * ipk * ijpj
2703
2704	IF ( l_north_nogather ) THEN
2705	!
2706	ztabr(:,:,:) = 0._wp
2707	ztabl(:,:,:) = 0._wp
2708
2709	DO jk = 1, ipk
2710	DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array
2711	ij = jj - nlcj + ijpj
2712	DO ji = nfsloop, nfeloop
2713	ztabl(ji,ij,jk) = pt3d(ji,jj,jk)
2714	END DO
2715	END DO
2716	END DO
2717
2718	DO jr = 1,nsndto
2719	IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
2720	CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2721	ENDIF
2722	END DO
2723	DO jr = 1,nsndto
2724	iproc = nfipproc(isendto(jr),jpnj)
2725	IF(iproc /= -1) THEN
2726	ilei = nleit (iproc+1)
2727	ildi = nldit (iproc+1)
2728	iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2729	ENDIF
2730	IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
2731	CALL mpprecv(5, zfoldwk, itaille, iproc)
2732	DO jk = 1, ipk
2733	DO jj = 1, ijpj
2734	DO ji = ildi, ilei
2735	ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)
2736	END DO
2737	END DO
2738	END DO
2739	ELSE IF( iproc == narea-1 ) THEN
2740	DO jk = 1, ipk
2741	DO jj = 1, ijpj
2742	DO ji = ildi, ilei
2743	ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)
2744	END DO
2745	END DO
2746	END DO
2747	ENDIF
2748	END DO
2749	IF (l_isend) THEN
2750	DO jr = 1,nsndto
2751	IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
2752	CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )
2753	ENDIF
2754	END DO
2755	ENDIF
2756	CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition
2757	DO jk = 1, ipk
2758	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
2759	ij = jj - nlcj + ijpj
2760	DO ji= 1, nlci
2761	pt3d(ji,jj,jk) = ztabl(ji,ij,jk)
2762	END DO
2763	END DO
2764	END DO
2765	!
2766	ELSE
2767	CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &
2768	& znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2769	!
2770	ztab(:,:,:) = 0._wp
2771	DO jr = 1, ndim_rank_north ! recover the global north array
2772	iproc = nrank_north(jr) + 1
2773	ildi = nldit (iproc)
2774	ilei = nleit (iproc)
2775	iilb = nimppt(iproc)
2776	DO jk = 1, ipk
2777	DO jj = 1, ijpj
2778	DO ji = ildi, ilei
2779	ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2780	END DO
2781	END DO
2782	END DO
2783	END DO
2784	CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
2785	!
2786	DO jk = 1, ipk
2787	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
2788	ij = jj - nlcj + ijpj
2789	DO ji= 1, nlci
2790	pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)
2791	END DO
2792	END DO
2793	END DO
2794	!
2795	ENDIF
2796	!
2797	! The ztab array has been either:
2798	! a. Fully populated by the mpi_allgather operation or
2799	! b. Had the active points for this domain and northern neighbours populated
2800	! by peer to peer exchanges
2801	! Either way the array may be folded by lbc_nfd and the result for the span of
2802	! this domain will be identical.
2803	!
2804	DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2805	DEALLOCATE( ztabl, ztabr )
2806	!
2807	END SUBROUTINE mpp_lbc_north_3d
2808
2809
2810	SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2811	!!---------------------------------------------------------------------
2812	!! * routine mpp_lbc_north_2d *
2813	!!
2814	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2815	!! in mpp configuration in case of jpn1 > 1 (for 2d array )
2816	!!
2817	!! ** Method : North fold condition and mpp with more than one proc
2818	!! in i-direction require a specific treatment. We gather
2819	!! the 4 northern lines of the global domain on 1 processor
2820	!! and apply lbc north-fold on this sub array. Then we
2821	!! scatter the north fold array back to the processors.
2822	!!
2823	!!----------------------------------------------------------------------
2824	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied
2825	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points
2826	! ! = T , U , V , F or W gridpoints
2827	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
2828	!! ! = 1. , the sign is kept
2829	INTEGER :: ji, jj, jr
2830	INTEGER :: ierr, itaille, ildi, ilei, iilb
2831	INTEGER :: ijpj, ijpjm1, ij, iproc
2832	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather
2833	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
2834	INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather
2835	! ! Workspace for message transfers avoiding mpi_allgather
2836	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab
2837	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: znorthloc, zfoldwk
2838	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio
2839	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztabl, ztabr
2840	INTEGER :: istatus(mpi_status_size)
2841	INTEGER :: iflag
2842	!!----------------------------------------------------------------------
2843	!
2844	ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )
2845	ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )
2846	!
2847	ijpj = 4
2848	ijpjm1 = 3
2849	!
2850	DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d
2851	ij = jj - nlcj + ijpj
2852	znorthloc(:,ij) = pt2d(:,jj)
2853	END DO
2854
2855	! ! Build in procs of ncomm_north the znorthgloio
2856	itaille = jpi * ijpj
2857	IF ( l_north_nogather ) THEN
2858	!
2859	! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2860	! (in nemo_northcomms) as being involved in this process' northern boundary exchange
2861	!
2862	ztabr(:,:) = 0
2863	ztabl(:,:) = 0
2864
2865	DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array
2866	ij = jj - nlcj + ijpj
2867	DO ji = nfsloop, nfeloop
2868	ztabl(ji,ij) = pt2d(ji,jj)
2869	END DO
2870	END DO
2871
2872	DO jr = 1,nsndto
2873	IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
2874	CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2875	ENDIF
2876	END DO
2877	DO jr = 1,nsndto
2878	iproc = nfipproc(isendto(jr),jpnj)
2879	IF( iproc /= -1 ) THEN
2880	ilei = nleit (iproc+1)
2881	ildi = nldit (iproc+1)
2882	iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2883	ENDIF
2884	IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
2885	CALL mpprecv(5, zfoldwk, itaille, iproc)
2886	DO jj = 1, ijpj
2887	DO ji = ildi, ilei
2888	ztabr(iilb+ji,jj) = zfoldwk(ji,jj)
2889	END DO
2890	END DO
2891	ELSEIF( iproc == narea-1 ) THEN
2892	DO jj = 1, ijpj
2893	DO ji = ildi, ilei
2894	ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)
2895	END DO
2896	END DO
2897	ENDIF
2898	END DO
2899	IF(l_isend) THEN
2900	DO jr = 1,nsndto
2901	IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
2902	CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2903	ENDIF
2904	END DO
2905	ENDIF
2906	CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition
2907	!
2908	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
2909	ij = jj - nlcj + ijpj
2910	DO ji = 1, nlci
2911	pt2d(ji,jj) = ztabl(ji,ij)
2912	END DO
2913	END DO
2914	!
2915	ELSE
2916	CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &
2917	& znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2918	!
2919	ztab(:,:) = 0._wp
2920	DO jr = 1, ndim_rank_north ! recover the global north array
2921	iproc = nrank_north(jr) + 1
2922	ildi = nldit (iproc)
2923	ilei = nleit (iproc)
2924	iilb = nimppt(iproc)
2925	DO jj = 1, ijpj
2926	DO ji = ildi, ilei
2927	ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2928	END DO
2929	END DO
2930	END DO
2931	CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
2932	!
2933	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
2934	ij = jj - nlcj + ijpj
2935	DO ji = 1, nlci
2936	pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2937	END DO
2938	END DO
2939	!
2940	ENDIF
2941	DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2942	DEALLOCATE( ztabl, ztabr )
2943	!
2944	END SUBROUTINE mpp_lbc_north_2d
2945
2946
2947	SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, kfld )
2948	!!---------------------------------------------------------------------
2949	!! * routine mpp_lbc_north_2d *
2950	!!
2951	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2952	!! in mpp configuration in case of jpn1 > 1
2953	!! (for multiple 2d arrays )
2954	!!
2955	!! ** Method : North fold condition and mpp with more than one proc
2956	!! in i-direction require a specific treatment. We gather
2957	!! the 4 northern lines of the global domain on 1 processor
2958	!! and apply lbc north-fold on this sub array. Then we
2959	!! scatter the north fold array back to the processors.
2960	!!
2961	!!----------------------------------------------------------------------
2962	TYPE( arrayptr ), DIMENSION(:), INTENT(inout) :: pt2d_array ! pointer array of 2D fields
2963	CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points
2964	REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold
2965	INTEGER , INTENT(in ) :: kfld ! number of variables contained in pt2d
2966	!
2967	INTEGER :: ji, jj, jr, jk
2968	INTEGER :: ierr, itaille, ildi, ilei, iilb
2969	INTEGER :: ijpj, ijpjm1, ij, iproc, iflag
2970	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather
2971	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
2972	INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather
2973	! ! Workspace for message transfers avoiding mpi_allgather
2974	INTEGER :: istatus(mpi_status_size)
2975	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab
2976	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk
2977	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
2978	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr
2979	!!----------------------------------------------------------------------
2980	!
2981	ALLOCATE( ztab(jpiglo,4,kfld), znorthloc (jpi,4,kfld), &
2982	& zfoldwk(jpi,4,kfld), znorthgloio(jpi,4,kfld,jpni), &
2983	& ztabl (jpi,4,kfld), ztabr(jpi*jpmaxngh, 4,kfld) )
2984	!
2985	ijpj = 4
2986	ijpjm1 = 3
2987	!
2988
2989	DO jk = 1, kfld
2990	DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable)
2991	ij = jj - nlcj + ijpj
2992	znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj)
2993	END DO
2994	END DO
2995	! ! Build in procs of ncomm_north the znorthgloio
2996	itaille = jpi * ijpj
2997
2998	IF ( l_north_nogather ) THEN
2999	!
3000	! Avoid the use of mpi_allgather by exchanging only with the processes already identified
3001	! (in nemo_northcomms) as being involved in this process' northern boundary exchange
3002	!
3003	ztabr(:,:,:) = 0._wp
3004	ztabl(:,:,:) = 0._wp
3005
3006	DO jk = 1, kfld
3007	DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array
3008	ij = jj - nlcj + ijpj
3009	DO ji = nfsloop, nfeloop
3010	ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj)
3011	END DO
3012	END DO
3013	END DO
3014
3015	DO jr = 1, nsndto
3016	IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
3017	CALL mppsend(5, znorthloc, itaille*kfld, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "kfld" times
3018	ENDIF
3019	END DO
3020	DO jr = 1, nsndto
3021	iproc = nfipproc(isendto(jr),jpnj)
3022	IF( iproc /= -1 ) THEN
3023	ilei = nleit (iproc+1)
3024	ildi = nldit (iproc+1)
3025	iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
3026	ENDIF
3027	IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
3028	CALL mpprecv(5, zfoldwk, itaille*kfld, iproc) ! Buffer expanded "kfld" times
3029	DO jk = 1 , kfld
3030	DO jj = 1, ijpj
3031	DO ji = ildi, ilei
3032	ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D
3033	END DO
3034	END DO
3035	END DO
3036	ELSEIF ( iproc == narea-1 ) THEN
3037	DO jk = 1, kfld
3038	DO jj = 1, ijpj
3039	DO ji = ildi, ilei
3040	ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D
3041	END DO
3042	END DO
3043	END DO
3044	ENDIF
3045	END DO
3046	IF( l_isend ) THEN
3047	DO jr = 1, nsndto
3048	IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
3049	CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
3050	ENDIF
3051	END DO
3052	ENDIF
3053	!
3054	DO ji = 1, kfld ! Loop to manage 3D variables
3055	CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition
3056	END DO
3057	!
3058	DO jk = 1, kfld
3059	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
3060	ij = jj - nlcj + ijpj
3061	DO ji = 1, nlci
3062	pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D
3063	END DO
3064	END DO
3065	END DO
3066
3067	!
3068	ELSE
3069	!
3070	CALL MPI_ALLGATHER( znorthloc , itaille*kfld, MPI_DOUBLE_PRECISION, &
3071	& znorthgloio, itaille*kfld, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3072	!
3073	ztab(:,:,:) = 0._wp
3074	DO jk = 1, kfld
3075	DO jr = 1, ndim_rank_north ! recover the global north array
3076	iproc = nrank_north(jr) + 1
3077	ildi = nldit (iproc)
3078	ilei = nleit (iproc)
3079	iilb = nimppt(iproc)
3080	DO jj = 1, ijpj
3081	DO ji = ildi, ilei
3082	ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
3083	END DO
3084	END DO
3085	END DO
3086	END DO
3087
3088	DO ji = 1, kfld
3089	CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition
3090	END DO
3091	!
3092	DO jk = 1, kfld
3093	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
3094	ij = jj - nlcj + ijpj
3095	DO ji = 1, nlci
3096	pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk)
3097	END DO
3098	END DO
3099	END DO
3100	!
3101	!
3102	ENDIF
3103	DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
3104	DEALLOCATE( ztabl, ztabr )
3105	!
3106	END SUBROUTINE mpp_lbc_north_2d_multiple
3107
3108
3109	SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
3110	!!---------------------------------------------------------------------
3111	!! * routine mpp_lbc_north_2d *
3112	!!
3113	!! ** Purpose : Ensure proper north fold horizontal bondary condition
3114	!! in mpp configuration in case of jpn1 > 1 and for 2d
3115	!! array with outer extra halo
3116	!!
3117	!! ** Method : North fold condition and mpp with more than one proc
3118	!! in i-direction require a specific treatment. We gather
3119	!! the 4+2*jpr2dj northern lines of the global domain on 1
3120	!! processor and apply lbc north-fold on this sub array.
3121	!! Then we scatter the north fold array back to the processors.
3122	!!
3123	!!----------------------------------------------------------------------
3124	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
3125	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
3126	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold
3127	!
3128	INTEGER :: ji, jj, jr
3129	INTEGER :: ierr, itaille, ildi, ilei, iilb
3130	INTEGER :: ijpj, ij, iproc
3131	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
3132	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
3133	!!----------------------------------------------------------------------
3134	!
3135	ALLOCATE( ztab_e(jpiglo,4+2jpr2dj), znorthloc_e(jpi,4+2jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
3136	!
3137	ijpj=4
3138	ztab_e(:,:) = 0._wp
3139
3140	ij = 0
3141	! put in znorthloc_e the last 4 jlines of pt2d
3142	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
3143	ij = ij + 1
3144	DO ji = 1, jpi
3145	znorthloc_e(ji,ij) = pt2d(ji,jj)
3146	END DO
3147	END DO
3148	!
3149	itaille = jpi * ( ijpj + 2 * jpr2dj )
3150	CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
3151	& znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3152	!
3153	DO jr = 1, ndim_rank_north ! recover the global north array
3154	iproc = nrank_north(jr) + 1
3155	ildi = nldit (iproc)
3156	ilei = nleit (iproc)
3157	iilb = nimppt(iproc)
3158	DO jj = 1, ijpj+2*jpr2dj
3159	DO ji = ildi, ilei
3160	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
3161	END DO
3162	END DO
3163	END DO
3164
3165	! 2. North-Fold boundary conditions
3166	! ----------------------------------
3167	CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
3168
3169	ij = jpr2dj
3170	!! Scatter back to pt2d
3171	DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
3172	ij = ij +1
3173	DO ji= 1, nlci
3174	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
3175	END DO
3176	END DO
3177	!
3178	DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3179	!
3180	END SUBROUTINE mpp_lbc_north_e
3181
3182
3183	SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
3184	!!----------------------------------------------------------------------
3185	!! * routine mpp_lnk_bdy_3d *
3186	!!
3187	!! ** Purpose : Message passing management
3188	!!
3189	!! ** Method : Use mppsend and mpprecv function for passing BDY boundaries
3190	!! between processors following neighboring subdomains.
3191	!! domain parameters
3192	!! nlci : first dimension of the local subdomain
3193	!! nlcj : second dimension of the local subdomain
3194	!! nbondi_bdy : mark for "east-west local boundary"
3195	!! nbondj_bdy : mark for "north-south local boundary"
3196	!! noea : number for local neighboring processors
3197	!! nowe : number for local neighboring processors
3198	!! noso : number for local neighboring processors
3199	!! nono : number for local neighboring processors
3200	!!
3201	!! ** Action : ptab with update value at its periphery
3202	!!
3203	!!----------------------------------------------------------------------
3204	REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
3205	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab grid point
3206	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary
3207	INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set
3208	!
3209	INTEGER :: ji, jj, jk, jl ! dummy loop indices
3210	INTEGER :: ipk ! 3rd dimension of the input array
3211	INTEGER :: imigr, iihom, ijhom ! local integers
3212	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
3213	REAL(wp) :: zland ! local scalar
3214	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
3215	!
3216	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north
3217	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east
3218	!!----------------------------------------------------------------------
3219	!
3220	ipk = SIZE( ptab, 3 )
3221	!
3222	ALLOCATE( zt3ns(jpi,jprecj,ipk,2), zt3sn(jpi,jprecj,ipk,2), &
3223	& zt3ew(jpj,jpreci,ipk,2), zt3we(jpj,jpreci,ipk,2) )
3224
3225	zland = 0._wp
3226
3227	! 1. standard boundary treatment
3228	! ------------------------------
3229	! ! East-West boundaries
3230	! !* Cyclic
3231	IF( nbondi == 2) THEN
3232	IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
3233	ptab( 1 ,:,:) = ptab(jpim1,:,:)
3234	ptab(jpi,:,:) = ptab( 2 ,:,:)
3235	ELSE
3236	IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point
3237	ptab(nlci-jpreci+1:jpi,:,:) = zland ! north
3238	ENDIF
3239	ELSEIF(nbondi == -1) THEN
3240	IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point
3241	ELSEIF(nbondi == 1) THEN
3242	ptab(nlci-jpreci+1:jpi,:,:) = zland ! north
3243	ENDIF !* closed
3244
3245	IF (nbondj == 2 .OR. nbondj == -1) THEN
3246	IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point
3247	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
3248	ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north
3249	ENDIF
3250	!
3251	! 2. East and west directions exchange
3252	! ------------------------------------
3253	! we play with the neigbours AND the row number because of the periodicity
3254	!
3255	SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions
3256	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
3257	iihom = nlci-nreci
3258	DO jl = 1, jpreci
3259	zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
3260	zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
3261	END DO
3262	END SELECT
3263	!
3264	! ! Migrations
3265	imigr = jpreci * jpj * ipk
3266	!
3267	SELECT CASE ( nbondi_bdy(ib_bdy) )
3268	CASE ( -1 )
3269	CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
3270	CASE ( 0 )
3271	CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
3272	CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
3273	CASE ( 1 )
3274	CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
3275	END SELECT
3276	!
3277	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3278	CASE ( -1 )
3279	CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
3280	CASE ( 0 )
3281	CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
3282	CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
3283	CASE ( 1 )
3284	CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
3285	END SELECT
3286	!
3287	SELECT CASE ( nbondi_bdy(ib_bdy) )
3288	CASE ( -1 )
3289	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3290	CASE ( 0 )
3291	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3292	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3293	CASE ( 1 )
3294	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3295	END SELECT
3296	!
3297	! ! Write Dirichlet lateral conditions
3298	iihom = nlci-jpreci
3299	!
3300	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3301	CASE ( -1 )
3302	DO jl = 1, jpreci
3303	ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
3304	END DO
3305	CASE ( 0 )
3306	DO jl = 1, jpreci
3307	ptab( jl,:,:) = zt3we(:,jl,:,2)
3308	ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
3309	END DO
3310	CASE ( 1 )
3311	DO jl = 1, jpreci
3312	ptab( jl,:,:) = zt3we(:,jl,:,2)
3313	END DO
3314	END SELECT
3315
3316	! 3. North and south directions
3317	! -----------------------------
3318	! always closed : we play only with the neigbours
3319	!
3320	IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions
3321	ijhom = nlcj-nrecj
3322	DO jl = 1, jprecj
3323	zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
3324	zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
3325	END DO
3326	ENDIF
3327	!
3328	! ! Migrations
3329	imigr = jprecj * jpi * ipk
3330	!
3331	SELECT CASE ( nbondj_bdy(ib_bdy) )
3332	CASE ( -1 )
3333	CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
3334	CASE ( 0 )
3335	CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3336	CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
3337	CASE ( 1 )
3338	CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3339	END SELECT
3340	!
3341	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3342	CASE ( -1 )
3343	CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3344	CASE ( 0 )
3345	CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3346	CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
3347	CASE ( 1 )
3348	CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
3349	END SELECT
3350	!
3351	SELECT CASE ( nbondj_bdy(ib_bdy) )
3352	CASE ( -1 )
3353	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3354	CASE ( 0 )
3355	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3356	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3357	CASE ( 1 )
3358	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3359	END SELECT
3360	!
3361	! ! Write Dirichlet lateral conditions
3362	ijhom = nlcj-jprecj
3363	!
3364	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3365	CASE ( -1 )
3366	DO jl = 1, jprecj
3367	ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
3368	END DO
3369	CASE ( 0 )
3370	DO jl = 1, jprecj
3371	ptab(:,jl ,:) = zt3sn(:,jl,:,2)
3372	ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
3373	END DO
3374	CASE ( 1 )
3375	DO jl = 1, jprecj
3376	ptab(:,jl,:) = zt3sn(:,jl,:,2)
3377	END DO
3378	END SELECT
3379
3380	! 4. north fold treatment
3381	! -----------------------
3382	!
3383	IF( npolj /= 0) THEN
3384	!
3385	SELECT CASE ( jpni )
3386	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
3387	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
3388	END SELECT
3389	!
3390	ENDIF
3391	!
3392	DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
3393	!
3394	END SUBROUTINE mpp_lnk_bdy_3d
3395
3396
3397	SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
3398	!!----------------------------------------------------------------------
3399	!! * routine mpp_lnk_bdy_2d *
3400	!!
3401	!! ** Purpose : Message passing management
3402	!!
3403	!! ** Method : Use mppsend and mpprecv function for passing BDY boundaries
3404	!! between processors following neighboring subdomains.
3405	!! domain parameters
3406	!! nlci : first dimension of the local subdomain
3407	!! nlcj : second dimension of the local subdomain
3408	!! nbondi_bdy : mark for "east-west local boundary"
3409	!! nbondj_bdy : mark for "north-south local boundary"
3410	!! noea : number for local neighboring processors
3411	!! nowe : number for local neighboring processors
3412	!! noso : number for local neighboring processors
3413	!! nono : number for local neighboring processors
3414	!!
3415	!! ** Action : ptab with update value at its periphery
3416	!!
3417	!!----------------------------------------------------------------------
3418	REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
3419	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
3420	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary
3421	INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set
3422	!
3423	INTEGER :: ji, jj, jl ! dummy loop indices
3424	INTEGER :: imigr, iihom, ijhom ! local integers
3425	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
3426	REAL(wp) :: zland
3427	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
3428	!
3429	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north
3430	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east
3431	!!----------------------------------------------------------------------
3432
3433	ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &
3434	& zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )
3435
3436	zland = 0._wp
3437
3438	! 1. standard boundary treatment
3439	! ------------------------------
3440	! ! East-West boundaries
3441	! !* Cyclic
3442	IF( nbondi == 2 ) THEN
3443	IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN
3444	ptab( 1 ,:) = ptab(jpim1,:)
3445	ptab(jpi,:) = ptab( 2 ,:)
3446	ELSE
3447	IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point
3448	ptab(nlci-jpreci+1:jpi ,:) = zland ! north
3449	ENDIF
3450	ELSEIF(nbondi == -1) THEN
3451	IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point
3452	ELSEIF(nbondi == 1) THEN
3453	ptab(nlci-jpreci+1:jpi ,:) = zland ! north
3454	ENDIF
3455	! !* closed
3456	IF( nbondj == 2 .OR. nbondj == -1 ) THEN
3457	IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point
3458	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
3459	ptab(:,nlcj-jprecj+1:jpj ) = zland ! north
3460	ENDIF
3461	!
3462	! 2. East and west directions exchange
3463	! ------------------------------------
3464	! we play with the neigbours AND the row number because of the periodicity
3465	!
3466	SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions
3467	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
3468	iihom = nlci-nreci
3469	DO jl = 1, jpreci
3470	zt2ew(:,jl,1) = ptab(jpreci+jl,:)
3471	zt2we(:,jl,1) = ptab(iihom +jl,:)
3472	END DO
3473	END SELECT
3474	!
3475	! ! Migrations
3476	imigr = jpreci * jpj
3477	!
3478	SELECT CASE ( nbondi_bdy(ib_bdy) )
3479	CASE ( -1 )
3480	CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
3481	CASE ( 0 )
3482	CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3483	CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
3484	CASE ( 1 )
3485	CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3486	END SELECT
3487	!
3488	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3489	CASE ( -1 )
3490	CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3491	CASE ( 0 )
3492	CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3493	CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3494	CASE ( 1 )
3495	CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3496	END SELECT
3497	!
3498	SELECT CASE ( nbondi_bdy(ib_bdy) )
3499	CASE ( -1 )
3500	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
3501	CASE ( 0 )
3502	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
3503	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err )
3504	CASE ( 1 )
3505	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err )
3506	END SELECT
3507	!
3508	! ! Write Dirichlet lateral conditions
3509	iihom = nlci-jpreci
3510	!
3511	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3512	CASE ( -1 )
3513	DO jl = 1, jpreci
3514	ptab(iihom+jl,:) = zt2ew(:,jl,2)
3515	END DO
3516	CASE ( 0 )
3517	DO jl = 1, jpreci
3518	ptab(jl ,:) = zt2we(:,jl,2)
3519	ptab(iihom+jl,:) = zt2ew(:,jl,2)
3520	END DO
3521	CASE ( 1 )
3522	DO jl = 1, jpreci
3523	ptab(jl ,:) = zt2we(:,jl,2)
3524	END DO
3525	END SELECT
3526
3527
3528	! 3. North and south directions
3529	! -----------------------------
3530	! always closed : we play only with the neigbours
3531	!
3532	IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions
3533	ijhom = nlcj-nrecj
3534	DO jl = 1, jprecj
3535	zt2sn(:,jl,1) = ptab(:,ijhom +jl)
3536	zt2ns(:,jl,1) = ptab(:,jprecj+jl)
3537	END DO
3538	ENDIF
3539	!
3540	! ! Migrations
3541	imigr = jprecj * jpi
3542	!
3543	SELECT CASE ( nbondj_bdy(ib_bdy) )
3544	CASE ( -1 )
3545	CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
3546	CASE ( 0 )
3547	CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3548	CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
3549	CASE ( 1 )
3550	CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3551	END SELECT
3552	!
3553	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3554	CASE ( -1 )
3555	CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3556	CASE ( 0 )
3557	CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3558	CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3559	CASE ( 1 )
3560	CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3561	END SELECT
3562	!
3563	SELECT CASE ( nbondj_bdy(ib_bdy) )
3564	CASE ( -1 )
3565	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
3566	CASE ( 0 )
3567	IF(l_isend) CALL mpi_wait (ml_req1, ml_stat, ml_err )
3568	IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )
3569	CASE ( 1 )
3570	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
3571	END SELECT
3572	!
3573	! ! Write Dirichlet lateral conditions
3574	ijhom = nlcj-jprecj
3575	!
3576	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3577	CASE ( -1 )
3578	DO jl = 1, jprecj
3579	ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3580	END DO
3581	CASE ( 0 )
3582	DO jl = 1, jprecj
3583	ptab(:,jl ) = zt2sn(:,jl,2)
3584	ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3585	END DO
3586	CASE ( 1 )
3587	DO jl = 1, jprecj
3588	ptab(:,jl) = zt2sn(:,jl,2)
3589	END DO
3590	END SELECT
3591
3592	! 4. north fold treatment
3593	! -----------------------
3594	!
3595	IF( npolj /= 0) THEN
3596	!
3597	SELECT CASE ( jpni )
3598	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
3599	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
3600	END SELECT
3601	!
3602	ENDIF
3603	!
3604	DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
3605	!
3606	END SUBROUTINE mpp_lnk_bdy_2d
3607
3608
3609	SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
3610	!!---------------------------------------------------------------------
3611	!! * routine mpp_init.opa *
3612	!!
3613	!! ** Purpose :: export and attach a MPI buffer for bsend
3614	!!
3615	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
3616	!! but classical mpi_init
3617	!!
3618	!! History :: 01/11 :: IDRIS initial version for IBM only
3619	!! 08/04 :: R. Benshila, generalisation
3620	!!---------------------------------------------------------------------
3621	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
3622	INTEGER , INTENT(inout) :: ksft
3623	INTEGER , INTENT( out) :: code
3624	INTEGER :: ierr, ji
3625	LOGICAL :: mpi_was_called
3626	!!---------------------------------------------------------------------
3627	!
3628	CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization
3629	IF ( code /= MPI_SUCCESS ) THEN
3630	DO ji = 1, SIZE(ldtxt)
3631	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
3632	END DO
3633	WRITE(*, cform_err)
3634	WRITE(, ) ' lib_mpp: Error in routine mpi_initialized'
3635	CALL mpi_abort( mpi_comm_world, code, ierr )
3636	ENDIF
3637	!
3638	IF( .NOT. mpi_was_called ) THEN
3639	CALL mpi_init( code )
3640	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
3641	IF ( code /= MPI_SUCCESS ) THEN
3642	DO ji = 1, SIZE(ldtxt)
3643	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
3644	END DO
3645	WRITE(*, cform_err)
3646	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
3647	CALL mpi_abort( mpi_comm_world, code, ierr )
3648	ENDIF
3649	ENDIF
3650	!
3651	IF( nn_buffer > 0 ) THEN
3652	WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1
3653	! Buffer allocation and attachment
3654	ALLOCATE( tampon(nn_buffer), stat = ierr )
3655	IF( ierr /= 0 ) THEN
3656	DO ji = 1, SIZE(ldtxt)
3657	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
3658	END DO
3659	WRITE(*, cform_err)
3660	WRITE(, ) ' lib_mpp: Error in ALLOCATE', ierr
3661	CALL mpi_abort( mpi_comm_world, code, ierr )
3662	END IF
3663	CALL mpi_buffer_attach( tampon, nn_buffer, code )
3664	ENDIF
3665	!
3666	END SUBROUTINE mpi_init_opa
3667
3668	SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
3669	!!---------------------------------------------------------------------
3670	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
3671	!!
3672	!! Modification of original codes written by David H. Bailey
3673	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
3674	!!---------------------------------------------------------------------
3675	INTEGER , INTENT(in) :: ilen, itype
3676	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
3677	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
3678	!
3679	REAL(wp) :: zerr, zt1, zt2 ! local work variables
3680	INTEGER :: ji, ztmp ! local scalar
3681	!!---------------------------------------------------------------------
3682
3683	ztmp = itype ! avoid compilation warning
3684
3685	DO ji=1,ilen
3686	! Compute ydda + yddb using Knuth's trick.
3687	zt1 = real(ydda(ji)) + real(yddb(ji))
3688	zerr = zt1 - real(ydda(ji))
3689	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
3690	+ aimag(ydda(ji)) + aimag(yddb(ji))
3691
3692	! The result is zt1 + zt2, after normalization.
3693	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
3694	END DO
3695
3696	END SUBROUTINE DDPDD_MPI
3697
3698
3699	SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
3700	!!---------------------------------------------------------------------
3701	!! * routine mpp_lbc_north_icb *
3702	!!
3703	!! ** Purpose : Ensure proper north fold horizontal bondary condition
3704	!! in mpp configuration in case of jpn1 > 1 and for 2d
3705	!! array with outer extra halo
3706	!!
3707	!! ** Method : North fold condition and mpp with more than one proc
3708	!! in i-direction require a specific treatment. We gather
3709	!! the 4+2*jpr2dj northern lines of the global domain on 1
3710	!! processor and apply lbc north-fold on this sub array.
3711	!! Then we scatter the north fold array back to the processors.
3712	!! This version accounts for an extra halo with icebergs.
3713	!!
3714	!!----------------------------------------------------------------------
3715	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo
3716	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
3717	! ! = T , U , V , F or W -points
3718	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
3719	!! ! north fold, = 1. otherwise
3720	INTEGER, OPTIONAL , INTENT(in ) :: pr2dj
3721	!
3722	INTEGER :: ji, jj, jr
3723	INTEGER :: ierr, itaille, ildi, ilei, iilb
3724	INTEGER :: ijpj, ij, iproc, ipr2dj
3725	!
3726	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
3727	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
3728	!!----------------------------------------------------------------------
3729	!
3730	ijpj=4
3731	IF( PRESENT(pr2dj) ) THEN ! use of additional halos
3732	ipr2dj = pr2dj
3733	ELSE
3734	ipr2dj = 0
3735	ENDIF
3736	ALLOCATE( ztab_e(jpiglo,4+2ipr2dj), znorthloc_e(jpi,4+2ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
3737	!
3738	ztab_e(:,:) = 0._wp
3739	!
3740	ij = 0
3741	! put in znorthloc_e the last 4 jlines of pt2d
3742	DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
3743	ij = ij + 1
3744	DO ji = 1, jpi
3745	znorthloc_e(ji,ij)=pt2d(ji,jj)
3746	END DO
3747	END DO
3748	!
3749	itaille = jpi * ( ijpj + 2 * ipr2dj )
3750	CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
3751	& znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3752	!
3753	DO jr = 1, ndim_rank_north ! recover the global north array
3754	iproc = nrank_north(jr) + 1
3755	ildi = nldit (iproc)
3756	ilei = nleit (iproc)
3757	iilb = nimppt(iproc)
3758	DO jj = 1, ijpj+2*ipr2dj
3759	DO ji = ildi, ilei
3760	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
3761	END DO
3762	END DO
3763	END DO
3764
3765
3766	! 2. North-Fold boundary conditions
3767	! ----------------------------------
3768	CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
3769
3770	ij = ipr2dj
3771	!! Scatter back to pt2d
3772	DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
3773	ij = ij +1
3774	DO ji= 1, nlci
3775	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
3776	END DO
3777	END DO
3778	!
3779	DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3780	!
3781	END SUBROUTINE mpp_lbc_north_icb
3782
3783
3784	SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
3785	!!----------------------------------------------------------------------
3786	!! * routine mpp_lnk_2d_icb *
3787	!!
3788	!! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs)
3789	!!
3790	!! ** Method : Use mppsend and mpprecv function for passing mask
3791	!! between processors following neighboring subdomains.
3792	!! domain parameters
3793	!! nlci : first dimension of the local subdomain
3794	!! nlcj : second dimension of the local subdomain
3795	!! jpri : number of rows for extra outer halo
3796	!! jprj : number of columns for extra outer halo
3797	!! nbondi : mark for "east-west local boundary"
3798	!! nbondj : mark for "north-south local boundary"
3799	!! noea : number for local neighboring processors
3800	!! nowe : number for local neighboring processors
3801	!! noso : number for local neighboring processors
3802	!! nono : number for local neighboring processors
3803	!!----------------------------------------------------------------------
3804	REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo
3805	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
3806	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold
3807	INTEGER , INTENT(in ) :: jpri
3808	INTEGER , INTENT(in ) :: jprj
3809	!
3810	INTEGER :: jl ! dummy loop indices
3811	INTEGER :: imigr, iihom, ijhom ! temporary integers
3812	INTEGER :: ipreci, iprecj ! temporary integers
3813	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
3814	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
3815	!!
3816	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
3817	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
3818	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
3819	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
3820	!!----------------------------------------------------------------------
3821
3822	ipreci = jpreci + jpri ! take into account outer extra 2D overlap area
3823	iprecj = jprecj + jprj
3824
3825
3826	! 1. standard boundary treatment
3827	! ------------------------------
3828	! Order matters Here !!!!
3829	!
3830	! ! East-West boundaries
3831	! !* Cyclic east-west
3832	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
3833	pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east
3834	pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west
3835	!
3836	ELSE !* closed
3837	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point
3838	pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north
3839	ENDIF
3840	!
3841
3842	! north fold treatment
3843	! -----------------------
3844	IF( npolj /= 0 ) THEN
3845	!
3846	SELECT CASE ( jpni )
3847	CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
3848	CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj )
3849	END SELECT
3850	!
3851	ENDIF
3852
3853	! 2. East and west directions exchange
3854	! ------------------------------------
3855	! we play with the neigbours AND the row number because of the periodicity
3856	!
3857	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
3858	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
3859	iihom = nlci-nreci-jpri
3860	DO jl = 1, ipreci
3861	r2dew(:,jl,1) = pt2d(jpreci+jl,:)
3862	r2dwe(:,jl,1) = pt2d(iihom +jl,:)
3863	END DO
3864	END SELECT
3865	!
3866	! ! Migrations
3867	imigr = ipreci * ( jpj + 2*jprj)
3868	!
3869	SELECT CASE ( nbondi )
3870	CASE ( -1 )
3871	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
3872	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3873	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3874	CASE ( 0 )
3875	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3876	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
3877	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3878	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3879	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3880	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3881	CASE ( 1 )
3882	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3883	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3884	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3885	END SELECT
3886	!
3887	! ! Write Dirichlet lateral conditions
3888	iihom = nlci - jpreci
3889	!
3890	SELECT CASE ( nbondi )
3891	CASE ( -1 )
3892	DO jl = 1, ipreci
3893	pt2d(iihom+jl,:) = r2dew(:,jl,2)
3894	END DO
3895	CASE ( 0 )
3896	DO jl = 1, ipreci
3897	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3898	pt2d( iihom+jl,:) = r2dew(:,jl,2)
3899	END DO
3900	CASE ( 1 )
3901	DO jl = 1, ipreci
3902	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3903	END DO
3904	END SELECT
3905
3906
3907	! 3. North and south directions
3908	! -----------------------------
3909	! always closed : we play only with the neigbours
3910	!
3911	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
3912	ijhom = nlcj-nrecj-jprj
3913	DO jl = 1, iprecj
3914	r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
3915	r2dns(:,jl,1) = pt2d(:,jprecj+jl)
3916	END DO
3917	ENDIF
3918	!
3919	! ! Migrations
3920	imigr = iprecj * ( jpi + 2*jpri )
3921	!
3922	SELECT CASE ( nbondj )
3923	CASE ( -1 )
3924	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
3925	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3926	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3927	CASE ( 0 )
3928	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3929	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
3930	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3931	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3932	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3933	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3934	CASE ( 1 )
3935	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3936	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3937	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3938	END SELECT
3939	!
3940	! ! Write Dirichlet lateral conditions
3941	ijhom = nlcj - jprecj
3942	!
3943	SELECT CASE ( nbondj )
3944	CASE ( -1 )
3945	DO jl = 1, iprecj
3946	pt2d(:,ijhom+jl) = r2dns(:,jl,2)
3947	END DO
3948	CASE ( 0 )
3949	DO jl = 1, iprecj
3950	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3951	pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
3952	END DO
3953	CASE ( 1 )
3954	DO jl = 1, iprecj
3955	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3956	END DO
3957	END SELECT
3958	!
3959	END SUBROUTINE mpp_lnk_2d_icb
3960
3961	#else
3962	!!----------------------------------------------------------------------
3963	!! Default case: Dummy module share memory computing
3964	!!----------------------------------------------------------------------
3965	USE in_out_manager
3966
3967	INTERFACE mpp_sum
3968	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
3969	END INTERFACE
3970	INTERFACE mpp_max
3971	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
3972	END INTERFACE
3973	INTERFACE mpp_min
3974	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3975	END INTERFACE
3976	INTERFACE mpp_minloc
3977	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3978	END INTERFACE
3979	INTERFACE mpp_maxloc
3980	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3981	END INTERFACE
3982	INTERFACE mpp_max_multiple
3983	MODULE PROCEDURE mppmax_real_multiple
3984	END INTERFACE
3985
3986	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
3987	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
3988	INTEGER :: ncomm_ice
3989	INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator
3990	!!----------------------------------------------------------------------
3991	CONTAINS
3992
3993	INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function
3994	INTEGER, INTENT(in) :: kumout
3995	lib_mpp_alloc = 0
3996	END FUNCTION lib_mpp_alloc
3997
3998	FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)
3999	INTEGER, OPTIONAL , INTENT(in ) :: localComm
4000	CHARACTER(len=*),DIMENSION(:) :: ldtxt
4001	CHARACTER(len=*) :: ldname
4002	INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop
4003	IF( PRESENT( localComm ) ) mpi_comm_opa = localComm
4004	function_value = 0
4005	IF( .FALSE. ) ldtxt(:) = 'never done'
4006	CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
4007	END FUNCTION mynode
4008
4009	SUBROUTINE mppsync ! Dummy routine
4010	END SUBROUTINE mppsync
4011
4012	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
4013	REAL , DIMENSION(:) :: parr
4014	INTEGER :: kdim
4015	INTEGER, OPTIONAL :: kcom
4016	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
4017	END SUBROUTINE mpp_sum_as
4018
4019	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
4020	REAL , DIMENSION(:,:) :: parr
4021	INTEGER :: kdim
4022	INTEGER, OPTIONAL :: kcom
4023	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
4024	END SUBROUTINE mpp_sum_a2s
4025
4026	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
4027	INTEGER, DIMENSION(:) :: karr
4028	INTEGER :: kdim
4029	INTEGER, OPTIONAL :: kcom
4030	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
4031	END SUBROUTINE mpp_sum_ai
4032
4033	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
4034	REAL :: psca
4035	INTEGER, OPTIONAL :: kcom
4036	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
4037	END SUBROUTINE mpp_sum_s
4038
4039	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
4040	integer :: kint
4041	INTEGER, OPTIONAL :: kcom
4042	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
4043	END SUBROUTINE mpp_sum_i
4044
4045	SUBROUTINE mppsum_realdd( ytab, kcom )
4046	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
4047	INTEGER , INTENT( in ), OPTIONAL :: kcom
4048	WRITE(,) 'mppsum_realdd: You should not have seen this print! error?', ytab
4049	END SUBROUTINE mppsum_realdd
4050
4051	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
4052	INTEGER , INTENT( in ) :: kdim ! size of ytab
4053	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
4054	INTEGER , INTENT( in ), OPTIONAL :: kcom
4055	WRITE(,) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
4056	END SUBROUTINE mppsum_a_realdd
4057
4058	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
4059	REAL , DIMENSION(:) :: parr
4060	INTEGER :: kdim
4061	INTEGER, OPTIONAL :: kcom
4062	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
4063	END SUBROUTINE mppmax_a_real
4064
4065	SUBROUTINE mppmax_real( psca, kcom )
4066	REAL :: psca
4067	INTEGER, OPTIONAL :: kcom
4068	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
4069	END SUBROUTINE mppmax_real
4070
4071	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
4072	REAL , DIMENSION(:) :: parr
4073	INTEGER :: kdim
4074	INTEGER, OPTIONAL :: kcom
4075	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
4076	END SUBROUTINE mppmin_a_real
4077
4078	SUBROUTINE mppmin_real( psca, kcom )
4079	REAL :: psca
4080	INTEGER, OPTIONAL :: kcom
4081	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
4082	END SUBROUTINE mppmin_real
4083
4084	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
4085	INTEGER, DIMENSION(:) :: karr
4086	INTEGER :: kdim
4087	INTEGER, OPTIONAL :: kcom
4088	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
4089	END SUBROUTINE mppmax_a_int
4090
4091	SUBROUTINE mppmax_int( kint, kcom)
4092	INTEGER :: kint
4093	INTEGER, OPTIONAL :: kcom
4094	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
4095	END SUBROUTINE mppmax_int
4096
4097	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
4098	INTEGER, DIMENSION(:) :: karr
4099	INTEGER :: kdim
4100	INTEGER, OPTIONAL :: kcom
4101	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
4102	END SUBROUTINE mppmin_a_int
4103
4104	SUBROUTINE mppmin_int( kint, kcom )
4105	INTEGER :: kint
4106	INTEGER, OPTIONAL :: kcom
4107	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
4108	END SUBROUTINE mppmin_int
4109
4110	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
4111	REAL :: pmin
4112	REAL , DIMENSION (:,:) :: ptab, pmask
4113	INTEGER :: ki, kj
4114	WRITE(,) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
4115	END SUBROUTINE mpp_minloc2d
4116
4117	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
4118	REAL :: pmin
4119	REAL , DIMENSION (:,:,:) :: ptab, pmask
4120	INTEGER :: ki, kj, kk
4121	WRITE(,) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
4122	END SUBROUTINE mpp_minloc3d
4123
4124	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
4125	REAL :: pmax
4126	REAL , DIMENSION (:,:) :: ptab, pmask
4127	INTEGER :: ki, kj
4128	WRITE(,) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
4129	END SUBROUTINE mpp_maxloc2d
4130
4131	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
4132	REAL :: pmax
4133	REAL , DIMENSION (:,:,:) :: ptab, pmask
4134	INTEGER :: ki, kj, kk
4135	WRITE(,) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
4136	END SUBROUTINE mpp_maxloc3d
4137
4138	SUBROUTINE mppstop
4139	STOP ! non MPP case, just stop the run
4140	END SUBROUTINE mppstop
4141
4142	SUBROUTINE mpp_ini_ice( kcom, knum )
4143	INTEGER :: kcom, knum
4144	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
4145	END SUBROUTINE mpp_ini_ice
4146
4147	SUBROUTINE mpp_ini_znl( knum )
4148	INTEGER :: knum
4149	WRITE(,) 'mpp_ini_znl: You should not have seen this print! error?', knum
4150	END SUBROUTINE mpp_ini_znl
4151
4152	SUBROUTINE mpp_comm_free( kcom )
4153	INTEGER :: kcom
4154	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?', kcom
4155	END SUBROUTINE mpp_comm_free
4156
4157	SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom )
4158	REAL, DIMENSION(:) :: ptab !
4159	INTEGER :: kdim !
4160	INTEGER, OPTIONAL :: kcom !
4161	WRITE(,) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim
4162	END SUBROUTINE mppmax_real_multiple
4163
4164	#endif
4165
4166	!!----------------------------------------------------------------------
4167	!! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines
4168	!!----------------------------------------------------------------------
4169
4170	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
4171	& cd6, cd7, cd8, cd9, cd10 )
4172	!!----------------------------------------------------------------------
4173	!! * ROUTINE stop_opa *
4174	!!
4175	!! ** Purpose : print in ocean.outpput file a error message and
4176	!! increment the error number (nstop) by one.
4177	!!----------------------------------------------------------------------
4178	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
4179	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
4180	!!----------------------------------------------------------------------
4181	!
4182	nstop = nstop + 1
4183	IF(lwp) THEN
4184	WRITE(numout,cform_err)
4185	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
4186	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
4187	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
4188	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
4189	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
4190	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
4191	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
4192	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
4193	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
4194	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
4195	ENDIF
4196	CALL FLUSH(numout )
4197	IF( numstp /= -1 ) CALL FLUSH(numstp )
4198	IF( numrun /= -1 ) CALL FLUSH(numrun )
4199	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
4200	!
4201	IF( cd1 == 'STOP' ) THEN
4202	IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
4203	CALL mppstop()
4204	ENDIF
4205	!
4206	END SUBROUTINE ctl_stop
4207
4208
4209	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
4210	& cd6, cd7, cd8, cd9, cd10 )
4211	!!----------------------------------------------------------------------
4212	!! * ROUTINE stop_warn *
4213	!!
4214	!! ** Purpose : print in ocean.outpput file a error message and
4215	!! increment the warning number (nwarn) by one.
4216	!!----------------------------------------------------------------------
4217	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
4218	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
4219	!!----------------------------------------------------------------------
4220	!
4221	nwarn = nwarn + 1
4222	IF(lwp) THEN
4223	WRITE(numout,cform_war)
4224	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
4225	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
4226	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
4227	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
4228	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
4229	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
4230	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
4231	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
4232	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
4233	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
4234	ENDIF
4235	CALL FLUSH(numout)
4236	!
4237	END SUBROUTINE ctl_warn
4238
4239
4240	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
4241	!!----------------------------------------------------------------------
4242	!! * ROUTINE ctl_opn *
4243	!!
4244	!! ** Purpose : Open file and check if required file is available.
4245	!!
4246	!! ** Method : Fortan open
4247	!!----------------------------------------------------------------------
4248	INTEGER , INTENT( out) :: knum ! logical unit to open
4249	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
4250	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
4251	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
4252	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
4253	INTEGER , INTENT(in ) :: klengh ! record length
4254	INTEGER , INTENT(in ) :: kout ! number of logical units for write
4255	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
4256	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
4257	!
4258	CHARACTER(len=80) :: clfile
4259	INTEGER :: iost
4260	!!----------------------------------------------------------------------
4261	!
4262	! adapt filename
4263	! ----------------
4264	clfile = TRIM(cdfile)
4265	IF( PRESENT( karea ) ) THEN
4266	IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
4267	ENDIF
4268	#if defined key_agrif
4269	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
4270	knum=Agrif_Get_Unit()
4271	#else
4272	knum=get_unit()
4273	#endif
4274	!
4275	iost=0
4276	IF( cdacce(1:6) == 'DIRECT' ) THEN
4277	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
4278	ELSE
4279	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
4280	ENDIF
4281	IF( iost == 0 ) THEN
4282	IF(ldwp) THEN
4283	WRITE(kout,*) ' file : ', clfile,' open ok'
4284	WRITE(kout,*) ' unit = ', knum
4285	WRITE(kout,*) ' status = ', cdstat
4286	WRITE(kout,*) ' form = ', cdform
4287	WRITE(kout,*) ' access = ', cdacce
4288	WRITE(kout,*)
4289	ENDIF
4290	ENDIF
4291	100 CONTINUE
4292	IF( iost /= 0 ) THEN
4293	IF(ldwp) THEN
4294	WRITE(kout,*)
4295	WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
4296	WRITE(kout,*) ' ======= === '
4297	WRITE(kout,*) ' unit = ', knum
4298	WRITE(kout,*) ' status = ', cdstat
4299	WRITE(kout,*) ' form = ', cdform
4300	WRITE(kout,*) ' access = ', cdacce
4301	WRITE(kout,*) ' iostat = ', iost
4302	WRITE(kout,*) ' we stop. verify the file '
4303	WRITE(kout,*)
4304	ENDIF
4305	CALL FLUSH( kout )
4306	STOP 'ctl_opn bad opening'
4307	ENDIF
4308	!
4309	END SUBROUTINE ctl_opn
4310
4311
4312	SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
4313	!!----------------------------------------------------------------------
4314	!! * ROUTINE ctl_nam *
4315	!!
4316	!! ** Purpose : Informations when error while reading a namelist
4317	!!
4318	!! ** Method : Fortan open
4319	!!----------------------------------------------------------------------
4320	INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist
4321	CHARACTER(len=*), INTENT(in ) :: cdnam ! group name of namelist for which error occurs
4322	CHARACTER(len=5) :: clios ! string to convert iostat in character for print
4323	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
4324	!!----------------------------------------------------------------------
4325	!
4326	WRITE (clios, '(I5.0)') kios
4327	IF( kios < 0 ) THEN
4328	CALL ctl_warn( 'end of record or file while reading namelist ' &
4329	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
4330	ENDIF
4331	!
4332	IF( kios > 0 ) THEN
4333	CALL ctl_stop( 'misspelled variable in namelist ' &
4334	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
4335	ENDIF
4336	kios = 0
4337	RETURN
4338	!
4339	END SUBROUTINE ctl_nam
4340
4341
4342	INTEGER FUNCTION get_unit()
4343	!!----------------------------------------------------------------------
4344	!! * FUNCTION get_unit *
4345	!!
4346	!! ** Purpose : return the index of an unused logical unit
4347	!!----------------------------------------------------------------------
4348	LOGICAL :: llopn
4349	!!----------------------------------------------------------------------
4350	!
4351	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
4352	llopn = .TRUE.
4353	DO WHILE( (get_unit < 998) .AND. llopn )
4354	get_unit = get_unit + 1
4355	INQUIRE( unit = get_unit, opened = llopn )
4356	END DO
4357	IF( (get_unit == 999) .AND. llopn ) THEN
4358	CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
4359	get_unit = -1
4360	ENDIF
4361	!
4362	END FUNCTION get_unit
4363
4364	!!----------------------------------------------------------------------
4365	END MODULE lib_mpp

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

Download in other formats: