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

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

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

Context Navigation

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

Last change on this file since 7037 was 7037, checked in by mocavero, 8 years ago
ORCA2_LIM_PISCES hybrid version update
Property svn:keywords set to `Id`
File size: 190.2 KB

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

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

Download in other formats: