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/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5779

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

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

Download in other formats: