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

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

lib_mpp.F90 in branches/2015/dev_r5302_CNRS18_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2015/dev_r5302_CNRS18_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5372

Last change on this file since 5372 was 5372, checked in by mcastril, 9 years ago
ticket #1523 Message Packing
Property svn:keywords set to `Id`
File size: 163.3 KB

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

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

Download in other formats: