Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

lib_mpp.f90 @ 15131

Last change on this file since 15131 was 15131, checked in by dbruciaferri, 3 years ago
introduce mes_init subroutine
File size: 180.3 KB

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

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

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

Context Navigation

source: NEMO/branches/UKMO/tools_r4.0-HEAD_dev_MEs/DOMAINcfg/src/lib_mpp.f90 @ 15131

Download in other formats: