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

Context Navigation

source: branches/UKMO/r6232_hadgem3_mct/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7456

Last change on this file since 7456 was 7456, checked in by jcastill, 8 years ago
Remove svn keys
File size: 164.4 KB

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

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

Download in other formats: