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/2013/dev_CMCC_2013/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2013/dev_CMCC_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4177

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

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

Download in other formats: