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

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

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

Context Navigation

source: branches/UKMO/dev_r5107_hadgem3_mct/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5284

Last change on this file since 5284 was 5284, checked in by dancopsey, 9 years ago
First attempt to convert OASIS3-MCT branch from NEMO3.5 to NEMO3.6. Original branch was dev/frrh/vn3.5_beta_hadgem3_mct
File size: 149.5 KB

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

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

Download in other formats: