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

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

lib_mpp.F90 in branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4314

Last change on this file since 4314 was 4314, checked in by cetlod, 10 years ago
v3.6_alpha : fix to compile without FPP key key_mpp_mpi, see ticket #1188
Property svn:keywords set to `Id`
File size: 163.0 KB

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

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

Download in other formats: