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/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7897

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

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

Download in other formats: