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

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

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

Context Navigation

source: branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8878

Last change on this file since 8878 was 8878, checked in by frrh, 6 years ago
Merge in http://fcm3/projects/NEMO.xm/log/branches/UKMO/dev_r8183_GC_couple_pkg revisions 8731:8734 inclusive
File size: 189.7 KB

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

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

Download in other formats: