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/2015/dev_MetOffice_merge_2015/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2015/dev_MetOffice_merge_2015/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6010

Last change on this file since 6010 was 6006, checked in by mathiot, 9 years ago
Merged ice sheet coupling branch
Property svn:keywords set to `Id`
File size: 179.1 KB

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

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

Download in other formats: