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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

lib_mpp.F90 in branches/2016/dev_r6519_HPC_4/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2016/dev_r6519_HPC_4/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7508

Last change on this file since 7508 was 7508, checked in by mocavero, 8 years ago
changes on code duplication and workshare construct
Property svn:keywords set to `Id`
File size: 190.6 KB

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

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

Download in other formats: