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 NEMO/branches/UKMO/r8395_coupling_sequence/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: NEMO/branches/UKMO/r8395_coupling_sequence/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 10762

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

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

Download in other formats: