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/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5619

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

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

Download in other formats: