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

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

lib_mpp.F90 in branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8280

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

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

Download in other formats: