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/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 3211

Last change on this file since 3211 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

Commit to bring the rest of the DCSE NEMO development branch
in line with the latest development version. This includes
array index re-ordering of all OPA_SRC/.

Property svn:keywords set to Id

File size: 124.3 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	!!----------------------------------------------------------------------
22
23	!!----------------------------------------------------------------------
24	!! ctl_stop : update momentum and tracer Kz from a tke scheme
25	!! ctl_warn : initialization, namelist read, and parameters control
26	!! ctl_opn : Open file and check if required file is available.
27	!! get_unit : give the index of an unused logical unit
28	!!----------------------------------------------------------------------
29	#if defined key_mpp_mpi
30	!!----------------------------------------------------------------------
31	!! 'key_mpp_mpi' MPI massively parallel processing library
32	!!----------------------------------------------------------------------
33	!! lib_mpp_alloc : allocate mpp arrays
34	!! mynode : indentify the processor unit
35	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
36	!! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays
37	!! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
38	!! mpprecv :
39	!! mppsend : SUBROUTINE mpp_ini_znl
40	!! mppscatter :
41	!! mppgather :
42	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
43	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
44	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
45	!! mpp_minloc :
46	!! mpp_maxloc :
47	!! mppsync :
48	!! mppstop :
49	!! mppobc : variant of mpp_lnk for open boundary condition
50	!! mpp_ini_north : initialisation of north fold
51	!! mpp_lbc_north : north fold processors gathering
52	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
53	!!----------------------------------------------------------------------
54	USE dom_oce ! ocean space and time domain
55	USE lbcnfd ! north fold treatment
56	USE in_out_manager ! I/O manager
57
58	IMPLICIT NONE
59	PRIVATE
60
61	PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn
62	PUBLIC mynode, mppstop, mppsync, mpp_comm_free
63	PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
64	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
65	PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
66	PUBLIC mppobc, mpp_ini_ice, mpp_ini_znl
67	PUBLIC mppsize
68	PUBLIC lib_mpp_alloc ! Called in nemogcm.F90
69
70	!! * Interfaces
71	!! define generic interface for these routine as they are called sometimes
72	!! with scalar arguments instead of array arguments, which causes problems
73	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
74	INTERFACE mpp_min
75	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
76	END INTERFACE
77	INTERFACE mpp_max
78	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
79	END INTERFACE
80	INTERFACE mpp_sum
81	# if defined key_mpp_rep
82	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
83	mppsum_realdd, mppsum_a_realdd
84	# else
85	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
86	# endif
87	END INTERFACE
88	INTERFACE mpp_lbc_north
89	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
90	END INTERFACE
91	INTERFACE mpp_minloc
92	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
93	END INTERFACE
94	INTERFACE mpp_maxloc
95	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
96	END INTERFACE
97
98	!! ========================= !!
99	!! MPI variable definition !!
100	!! ========================= !!
101	!$AGRIF_DO_NOT_TREAT
102	INCLUDE 'mpif.h'
103	!$AGRIF_END_DO_NOT_TREAT
104
105	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
106
107	INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)
108
109	INTEGER :: mppsize ! number of process
110	INTEGER :: mpprank ! process number [ 0 - size-1 ]
111	!$AGRIF_DO_NOT_TREAT
112	INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator
113	!$AGRIF_END_DO_NOT_TREAT
114
115	# if defined key_mpp_rep
116	INTEGER :: MPI_SUMDD
117	# endif
118
119	! variables used in case of sea-ice
120	INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice
121	INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)
122	INTEGER :: ndim_rank_ice ! number of 'ice' processors
123	INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm
124	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice
125
126	! variables used for zonal integration
127	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
128	LOGICAL, PUBLIC :: l_znl_root ! True on the 'left'most processor on the same row
129	INTEGER :: ngrp_znl ! group ID for the znl processors
130	INTEGER :: ndim_rank_znl ! number of processors on the same zonal average
131	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl,
132	! ! number of the procs into the same znl domain
133
134	! North fold condition in mpp_mpi with jpni > 1
135	INTEGER :: ngrp_world ! group ID for the world processors
136	INTEGER :: ngrp_opa ! group ID for the opa processors
137	INTEGER :: ngrp_north ! group ID for the northern processors (to be fold)
138	INTEGER :: ncomm_north ! communicator made by the processors belonging to ngrp_north
139	INTEGER :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)
140	INTEGER :: njmppmax ! value of njmpp for the processors of the northern line
141	INTEGER :: north_root ! number (in the comm_opa) of proc 0 in the northern comm
142	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north ! dimension ndim_rank_north
143
144	! Type of send : standard, buffered, immediate
145	CHARACTER(len=1) :: cn_mpi_send = 'S' ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
146	LOGICAL :: l_isend = .FALSE. ! isend use indicator (T if cn_mpi_send='I')
147	INTEGER :: nn_buffer = 0 ! size of the buffer in case of mpi_bsend
148
149	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend
150
151	! message passing arrays
152	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4ns, t4sn ! 2 x 3d for north-south & south-north
153	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4ew, t4we ! 2 x 3d for east-west & west-east
154	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4p1, t4p2 ! 2 x 3d for north fold
155	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3ns, t3sn ! 3d for north-south & south-north
156	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3ew, t3we ! 3d for east-west & west-east
157	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3p1, t3p2 ! 3d for north fold
158	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2ns, t2sn ! 2d for north-south & south-north
159	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2ew, t2we ! 2d for east-west & west-east
160	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2p1, t2p2 ! 2d for north fold
161	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: tr2ns, tr2sn ! 2d for north-south & south-north + extra outer halo
162	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: tr2ew, tr2we ! 2d for east-west & west-east + extra outer halo
163
164	! Arrays used in mpp_lbc_north_3d()
165	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: ztab, znorthloc
166	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio
167
168	! Arrays used in mpp_lbc_north_2d()
169	REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_2d, znorthloc_2d
170	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_2d
171
172	! Arrays used in mpp_lbc_north_e()
173	REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_e, znorthloc_e
174	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_e
175
176	!! * Control permutation of array indices
177	# include "dom_oce_ftrans.h90"
178	!! These arrays are all private to the module
179	!FTRANS t4ns :I :I :z :I :I
180	!FTRANS t4sn :I :I :z :I :I
181	!FTRANS t4ew :I :I :z :I :I
182	!FTRANS t4we :I :I :z :I :I
183	!FTRANS t3ns :I :I :z :I
184	!FTRANS t3sn :I :I :z :I
185	!FTRANS t3ew :I :I :z :I
186	!FTRANS t3we :I :I :z :I
187	!FTRANS ztab :I :I :z
188	!FTRANS znorthloc :I :I :z
189	!FTRANS znorthgloio :I :I :z :I
190
191	!!----------------------------------------------------------------------
192	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
193	!! $Id$
194	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
195	!!----------------------------------------------------------------------
196	CONTAINS
197
198	INTEGER FUNCTION lib_mpp_alloc( kumout )
199	!!----------------------------------------------------------------------
200	!! * routine lib_mpp_alloc *
201	!!----------------------------------------------------------------------
202	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
203	!!----------------------------------------------------------------------
204	!
205	ALLOCATE( t4ns(jpi,jprecj,jpk,2,2) , t4sn(jpi,jprecj,jpk,2,2) , &
206	& t4ew(jpj,jpreci,jpk,2,2) , t4we(jpj,jpreci,jpk,2,2) , &
207	& t4p1(jpi,jprecj,jpk,2,2) , t4p2(jpi,jprecj,jpk,2,2) , &
208	& t3ns(jpi,jprecj,jpk,2) , t3sn(jpi,jprecj,jpk,2) , &
209	& t3ew(jpj,jpreci,jpk,2) , t3we(jpj,jpreci,jpk,2) , &
210	& t3p1(jpi,jprecj,jpk,2) , t3p2(jpi,jprecj,jpk,2) , &
211	& t2ns(jpi,jprecj ,2) , t2sn(jpi,jprecj ,2) , &
212	& t2ew(jpj,jpreci ,2) , t2we(jpj,jpreci ,2) , &
213	& t2p1(jpi,jprecj ,2) , t2p2(jpi,jprecj ,2) , &
214	!
215	& tr2ns(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) , &
216	& tr2sn(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) , &
217	& tr2ew(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) , &
218	& tr2we(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) , &
219	!
220	& ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) , &
221	!
222	& ztab_2d(jpiglo,4) , znorthloc_2d(jpi,4) , znorthgloio_2d(jpi,4,jpni) , &
223	!
224	& ztab_e(jpiglo,4+2jpr2dj) , znorthloc_e(jpi,4+2jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) , &
225	!
226	& STAT=lib_mpp_alloc )
227	!
228	IF( lib_mpp_alloc /= 0 ) THEN
229	WRITE(kumout,cform_war)
230	WRITE(kumout,*) 'lib_mpp_alloc : failed to allocate arrays'
231	ENDIF
232	!
233	END FUNCTION lib_mpp_alloc
234
235
236	FUNCTION mynode( ldtxt, kumnam, kstop, localComm )
237	!!----------------------------------------------------------------------
238	!! * routine mynode *
239	!!
240	!! ** Purpose : Find processor unit
241	!!----------------------------------------------------------------------
242	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
243	INTEGER , INTENT(in ) :: kumnam ! namelist logical unit
244	INTEGER , INTENT(inout) :: kstop ! stop indicator
245	INTEGER, OPTIONAL , INTENT(in ) :: localComm
246	!
247	INTEGER :: mynode, ierr, code, ji, ii
248	LOGICAL :: mpi_was_called
249	!
250	NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij
251	!!----------------------------------------------------------------------
252	!
253	ii = 1
254	WRITE(ldtxt(ii),*) ; ii = ii + 1
255	WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1
256	WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1
257	!
258	jpni = -1; jpnj = -1; jpnij = -1
259	REWIND( kumnam ) ! Namelist namrun : parameters of the run
260	READ ( kumnam, nammpp )
261	! ! control print
262	WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1
263	WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
264	WRITE(ldtxt(ii),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer ; ii = ii + 1
265
266	#if defined key_agrif
267	IF( .NOT. Agrif_Root() ) THEN
268	jpni = Agrif_Parent(jpni )
269	jpnj = Agrif_Parent(jpnj )
270	jpnij = Agrif_Parent(jpnij)
271	ENDIF
272	#endif
273
274	IF(jpnij < 1)THEN
275	! If jpnij is not specified in namelist then we calculate it - this
276	! means there will be no land cutting out.
277	jpnij = jpni * jpnj
278	END IF
279
280	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
281	WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically'; ii = ii + 1
282	ELSE
283	WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni; ii = ii + 1
284	WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj; ii = ii + 1
285	WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij; ii = ii +1
286	END IF
287
288	CALL mpi_initialized ( mpi_was_called, code )
289	IF( code /= MPI_SUCCESS ) THEN
290	DO ji = 1, SIZE(ldtxt)
291	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
292	END DO
293	WRITE(*, cform_err)
294	WRITE(, ) 'lib_mpp: Error in routine mpi_initialized'
295	CALL mpi_abort( mpi_comm_world, code, ierr )
296	ENDIF
297
298	IF( mpi_was_called ) THEN
299	!
300	SELECT CASE ( cn_mpi_send )
301	CASE ( 'S' ) ! Standard mpi send (blocking)
302	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
303	CASE ( 'B' ) ! Buffer mpi send (blocking)
304	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
305	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
306	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
307	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
308	l_isend = .TRUE.
309	CASE DEFAULT
310	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
311	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
312	kstop = kstop + 1
313	END SELECT
314	ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
315	WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1
316	WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1
317	kstop = kstop + 1
318	ELSE
319	SELECT CASE ( cn_mpi_send )
320	CASE ( 'S' ) ! Standard mpi send (blocking)
321	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
322	CALL mpi_init( ierr )
323	CASE ( 'B' ) ! Buffer mpi send (blocking)
324	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
325	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
326	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
327	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
328	l_isend = .TRUE.
329	CALL mpi_init( ierr )
330	CASE DEFAULT
331	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
332	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
333	kstop = kstop + 1
334	END SELECT
335	!
336	ENDIF
337
338	IF( PRESENT(localComm) ) THEN
339	IF( Agrif_Root() ) THEN
340	mpi_comm_opa = localComm
341	ENDIF
342	ELSE
343	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
344	IF( code /= MPI_SUCCESS ) THEN
345	DO ji = 1, SIZE(ldtxt)
346	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
347	END DO
348	WRITE(*, cform_err)
349	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
350	CALL mpi_abort( mpi_comm_world, code, ierr )
351	ENDIF
352	ENDIF
353
354	CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
355	CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
356	mynode = mpprank
357	!
358	#if defined key_mpp_rep
359	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
360	#endif
361	!
362	END FUNCTION mynode
363
364
365	SUBROUTINE mpp_lnk_3d( ptab3d, cd_type, psgn, cd_mpp, pval )
366	!!----------------------------------------------------------------------
367	!! * routine mpp_lnk_3d *
368	!!
369	!! ** Purpose : Message passing manadgement
370	!!
371	!! ** Method : Use mppsend and mpprecv function for passing mask
372	!! between processors following neighboring subdomains.
373	!! domain parameters
374	!! nlci : first dimension of the local subdomain
375	!! nlcj : second dimension of the local subdomain
376	!! nbondi : mark for "east-west local boundary"
377	!! nbondj : mark for "north-south local boundary"
378	!! noea : number for local neighboring processors
379	!! nowe : number for local neighboring processors
380	!! noso : number for local neighboring processors
381	!! nono : number for local neighboring processors
382	!!
383	!! ** Action : ptab with update value at its periphery
384	!!
385	!!----------------------------------------------------------------------
386	!FTRANS ptab3d :I :I :z
387	!! DCSE_NEMO: work around a deficiency in ftrans
388	! REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab3d ! 3D array on which the boundary condition is applied
389	REAL(wp), INTENT(inout) :: ptab3d(jpi,jpj,jpk)
390	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
391	! ! = T , U , V , F , W points
392	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
393	! ! = 1. , the sign is kept
394	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
395	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
396	!!
397	INTEGER :: ji, jj, jk, jl ! dummy loop indices
398	INTEGER :: imigr, iihom, ijhom ! temporary integers
399	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
400	REAL(wp) :: zland
401	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
402	!!----------------------------------------------------------------------
403
404	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
405	ELSE ; zland = 0.e0 ! zero by default
406	ENDIF
407
408	! 1. standard boundary treatment
409	! ------------------------------
410	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
411	!
412	! WARNING ptab3d is defined only between nld and nle
413	#if defined key_z_first
414	DO jj = nlcj+1, jpj ! added line(s) (inner only)
415	DO jk = 1, jpk
416	#else
417	DO jk = 1, jpk
418	DO jj = nlcj+1, jpj ! added line(s) (inner only)
419	#endif
420	ptab3d(nldi :nlei , jj ,jk) = ptab3d(nldi:nlei, nlej,jk)
421	ptab3d(1 :nldi-1, jj ,jk) = ptab3d(nldi , nlej,jk)
422	ptab3d(nlei+1:nlci , jj ,jk) = ptab3d( nlei, nlej,jk)
423	END DO
424	#if defined key_z_first
425	END DO
426	DO ji = nlci+1, jpi ! added column(s) (full)
427	DO jk = 1, jpk
428	#else
429	DO ji = nlci+1, jpi ! added column(s) (full)
430	#endif
431	ptab3d(ji ,nldj :nlej ,jk) = ptab3d( nlei,nldj:nlej,jk)
432	ptab3d(ji ,1 :nldj-1,jk) = ptab3d( nlei,nldj ,jk)
433	ptab3d(ji ,nlej+1:jpj ,jk) = ptab3d( nlei, nlej,jk)
434	END DO
435	END DO
436	!
437	ELSE ! standard close or cyclic treatment
438	!
439	! ! East-West boundaries
440	! !* Cyclic east-west
441	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
442	ptab3d( 1 ,:,:) = ptab3d(jpim1,:,:)
443	ptab3d(jpi,:,:) = ptab3d( 2 ,:,:)
444	ELSE !* closed
445	IF( .NOT. cd_type == 'F' ) ptab3d( 1 :jpreci,:,:) = zland ! south except F-point
446	ptab3d(nlci-jpreci+1:jpi ,:,:) = zland ! north
447	ENDIF
448	! ! North-South boundaries (always closed)
449	IF( .NOT. cd_type == 'F' ) ptab3d(:, 1 :jprecj,:) = zland ! south except F-point
450	ptab3d(:,nlcj-jprecj+1:jpj ,:) = zland ! north
451	!
452	ENDIF
453
454	! 2. East and west directions exchange
455	! ------------------------------------
456	! we play with the neigbours AND the row number because of the periodicity
457	!
458	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
459	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
460	iihom = nlci-nreci
461	DO jl = 1, jpreci
462	t3ew(:,jl,:,1) = ptab3d(jpreci+jl,:,:)
463	t3we(:,jl,:,1) = ptab3d(iihom +jl,:,:)
464	END DO
465	END SELECT
466	!
467	! ! Migrations
468	imigr = jpreci * jpj * jpk
469	!
470	SELECT CASE ( nbondi )
471	CASE ( -1 )
472	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
473	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
474	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
475	CASE ( 0 )
476	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
477	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
478	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
479	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
480	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
481	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
482	CASE ( 1 )
483	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
484	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
485	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
486	END SELECT
487	!
488	! ! Write Dirichlet lateral conditions
489	iihom = nlci-jpreci
490	!
491	SELECT CASE ( nbondi )
492	CASE ( -1 )
493	DO jl = 1, jpreci
494	ptab3d(iihom+jl,:,:) = t3ew(:,jl,:,2)
495	END DO
496	CASE ( 0 )
497	DO jl = 1, jpreci
498	ptab3d(jl ,:,:) = t3we(:,jl,:,2)
499	ptab3d(iihom+jl,:,:) = t3ew(:,jl,:,2)
500	END DO
501	CASE ( 1 )
502	DO jl = 1, jpreci
503	ptab3d(jl ,:,:) = t3we(:,jl,:,2)
504	END DO
505	END SELECT
506
507
508	! 3. North and south directions
509	! -----------------------------
510	! always closed : we play only with the neigbours
511	!
512	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
513	ijhom = nlcj-nrecj
514	DO jl = 1, jprecj
515	t3sn(:,jl,:,1) = ptab3d(:,ijhom +jl,:)
516	t3ns(:,jl,:,1) = ptab3d(:,jprecj+jl,:)
517	END DO
518	ENDIF
519	!
520	! ! Migrations
521	imigr = jprecj * jpi * jpk
522	!
523	SELECT CASE ( nbondj )
524	CASE ( -1 )
525	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
526	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
527	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
528	CASE ( 0 )
529	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
530	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
531	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
532	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
533	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
534	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
535	CASE ( 1 )
536	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
537	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
538	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
539	END SELECT
540	!
541	! ! Write Dirichlet lateral conditions
542	ijhom = nlcj-jprecj
543	!
544	SELECT CASE ( nbondj )
545	CASE ( -1 )
546	DO jl = 1, jprecj
547	ptab3d(:,ijhom+jl,:) = t3ns(:,jl,:,2)
548	END DO
549	CASE ( 0 )
550	DO jl = 1, jprecj
551	ptab3d(:,jl ,:) = t3sn(:,jl,:,2)
552	ptab3d(:,ijhom+jl,:) = t3ns(:,jl,:,2)
553	END DO
554	CASE ( 1 )
555	DO jl = 1, jprecj
556	ptab3d(:,jl,:) = t3sn(:,jl,:,2)
557	END DO
558	END SELECT
559
560
561	! 4. north fold treatment
562	! -----------------------
563	!
564	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
565	!
566	SELECT CASE ( jpni )
567	CASE ( 1 ) ; CALL lbc_nfd ( ptab3d, cd_type, psgn ) ! only 1 northern proc, no mpp
568	CASE DEFAULT ; CALL mpp_lbc_north( ptab3d, cd_type, psgn ) ! for all northern procs.
569	END SELECT
570	!
571	ENDIF
572	!
573	END SUBROUTINE mpp_lnk_3d
574
575
576	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
577	!!----------------------------------------------------------------------
578	!! * routine mpp_lnk_2d *
579	!!
580	!! ** Purpose : Message passing manadgement for 2d array
581	!!
582	!! ** Method : Use mppsend and mpprecv function for passing mask
583	!! between processors following neighboring subdomains.
584	!! domain parameters
585	!! nlci : first dimension of the local subdomain
586	!! nlcj : second dimension of the local subdomain
587	!! nbondi : mark for "east-west local boundary"
588	!! nbondj : mark for "north-south local boundary"
589	!! noea : number for local neighboring processors
590	!! nowe : number for local neighboring processors
591	!! noso : number for local neighboring processors
592	!! nono : number for local neighboring processors
593	!!
594	!!----------------------------------------------------------------------
595	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
596	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
597	! ! = T , U , V , F , W and I points
598	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
599	! ! = 1. , the sign is kept
600	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
601	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
602	!!
603	INTEGER :: ji, jj, jl ! dummy loop indices
604	INTEGER :: imigr, iihom, ijhom ! temporary integers
605	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
606	REAL(wp) :: zland
607	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
608	!!----------------------------------------------------------------------
609
610	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
611	ELSE ; zland = 0.e0 ! zero by default
612	ENDIF
613
614	! 1. standard boundary treatment
615	! ------------------------------
616	!
617	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
618	!
619	! WARNING pt2d is defined only between nld and nle
620	DO jj = nlcj+1, jpj ! added line(s) (inner only)
621	pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej)
622	pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej)
623	pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej)
624	END DO
625	DO ji = nlci+1, jpi ! added column(s) (full)
626	pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej)
627	pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj )
628	pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej)
629	END DO
630	!
631	ELSE ! standard close or cyclic treatment
632	!
633	! ! East-West boundaries
634	IF( nbondi == 2 .AND. & ! Cyclic east-west
635	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
636	pt2d( 1 ,:) = pt2d(jpim1,:) ! west
637	pt2d(jpi,:) = pt2d( 2 ,:) ! east
638	ELSE ! closed
639	IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point
640	pt2d(nlci-jpreci+1:jpi ,:) = zland ! north
641	ENDIF
642	! ! North-South boundaries (always closed)
643	IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point
644	pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north
645	!
646	ENDIF
647
648	! 2. East and west directions exchange
649	! ------------------------------------
650	! we play with the neigbours AND the row number because of the periodicity
651	!
652	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
653	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
654	iihom = nlci-nreci
655	DO jl = 1, jpreci
656	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
657	t2we(:,jl,1) = pt2d(iihom +jl,:)
658	END DO
659	END SELECT
660	!
661	! ! Migrations
662	imigr = jpreci * jpj
663	!
664	SELECT CASE ( nbondi )
665	CASE ( -1 )
666	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
667	CALL mpprecv( 1, t2ew(1,1,2), imigr )
668	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
669	CASE ( 0 )
670	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
671	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
672	CALL mpprecv( 1, t2ew(1,1,2), imigr )
673	CALL mpprecv( 2, t2we(1,1,2), imigr )
674	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
675	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
676	CASE ( 1 )
677	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
678	CALL mpprecv( 2, t2we(1,1,2), imigr )
679	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
680	END SELECT
681	!
682	! ! Write Dirichlet lateral conditions
683	iihom = nlci - jpreci
684	!
685	SELECT CASE ( nbondi )
686	CASE ( -1 )
687	DO jl = 1, jpreci
688	pt2d(iihom+jl,:) = t2ew(:,jl,2)
689	END DO
690	CASE ( 0 )
691	DO jl = 1, jpreci
692	pt2d(jl ,:) = t2we(:,jl,2)
693	pt2d(iihom+jl,:) = t2ew(:,jl,2)
694	END DO
695	CASE ( 1 )
696	DO jl = 1, jpreci
697	pt2d(jl ,:) = t2we(:,jl,2)
698	END DO
699	END SELECT
700
701
702	! 3. North and south directions
703	! -----------------------------
704	! always closed : we play only with the neigbours
705	!
706	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
707	ijhom = nlcj-nrecj
708	DO jl = 1, jprecj
709	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
710	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
711	END DO
712	ENDIF
713	!
714	! ! Migrations
715	imigr = jprecj * jpi
716	!
717	SELECT CASE ( nbondj )
718	CASE ( -1 )
719	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
720	CALL mpprecv( 3, t2ns(1,1,2), imigr )
721	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
722	CASE ( 0 )
723	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
724	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
725	CALL mpprecv( 3, t2ns(1,1,2), imigr )
726	CALL mpprecv( 4, t2sn(1,1,2), imigr )
727	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
728	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
729	CASE ( 1 )
730	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
731	CALL mpprecv( 4, t2sn(1,1,2), imigr )
732	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
733	END SELECT
734	!
735	! ! Write Dirichlet lateral conditions
736	ijhom = nlcj - jprecj
737	!
738	SELECT CASE ( nbondj )
739	CASE ( -1 )
740	DO jl = 1, jprecj
741	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
742	END DO
743	CASE ( 0 )
744	DO jl = 1, jprecj
745	pt2d(:,jl ) = t2sn(:,jl,2)
746	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
747	END DO
748	CASE ( 1 )
749	DO jl = 1, jprecj
750	pt2d(:,jl ) = t2sn(:,jl,2)
751	END DO
752	END SELECT
753
754
755	! 4. north fold treatment
756	! -----------------------
757	!
758	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
759	!
760	SELECT CASE ( jpni )
761	CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp
762	CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.
763	END SELECT
764	!
765	ENDIF
766	!
767	END SUBROUTINE mpp_lnk_2d
768
769
770	SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
771	!!----------------------------------------------------------------------
772	!! * routine mpp_lnk_3d_gather *
773	!!
774	!! ** Purpose : Message passing management for two 3D arrays
775	!!
776	!! ** Method : Use mppsend and mpprecv function for passing mask
777	!! between processors following neighboring subdomains.
778	!! domain parameters
779	!! nlci : first dimension of the local subdomain
780	!! nlcj : second dimension of the local subdomain
781	!! nbondi : mark for "east-west local boundary"
782	!! nbondj : mark for "north-south local boundary"
783	!! noea : number for local neighboring processors
784	!! nowe : number for local neighboring processors
785	!! noso : number for local neighboring processors
786	!! nono : number for local neighboring processors
787	!!
788	!! ** Action : ptab1 and ptab2 with update value at its periphery
789	!!
790	!!----------------------------------------------------------------------
791	!FTRANS ptab1 :I :I :z
792	!FTRANS ptab2 :I :I :z
793	!! DCSE_NEMO: work around a deficiency in ftrans
794	! REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which
795	! REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied
796	REAL(wp), INTENT(inout) :: ptab1(jpi,jpj,jpk)
797	REAL(wp), INTENT(inout) :: ptab2(jpi,jpj,jpk)
798	CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays
799	CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points
800	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
801	!! ! = 1. , the sign is kept
802	INTEGER :: jl ! dummy loop indices
803	INTEGER :: imigr, iihom, ijhom ! temporary integers
804	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
805	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
806	!!----------------------------------------------------------------------
807
808	! 1. standard boundary treatment
809	! ------------------------------
810	! ! East-West boundaries
811	! !* Cyclic east-west
812	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
813	ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
814	ptab1(jpi,:,:) = ptab1( 2 ,:,:)
815	ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
816	ptab2(jpi,:,:) = ptab2( 2 ,:,:)
817	ELSE !* closed
818	IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point
819	IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0
820	ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north
821	ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
822	ENDIF
823
824
825	! ! North-South boundaries
826	IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0 ! south except at F-point
827	IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e0
828	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 ! north
829	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
830
831
832	! 2. East and west directions exchange
833	! ------------------------------------
834	! we play with the neigbours AND the row number because of the periodicity
835	!
836	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
837	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
838	iihom = nlci-nreci
839	DO jl = 1, jpreci
840	t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
841	t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
842	t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
843	t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
844	END DO
845	END SELECT
846	!
847	! ! Migrations
848	imigr = jpreci * jpj * jpk *2
849	!
850	SELECT CASE ( nbondi )
851	CASE ( -1 )
852	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
853	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
854	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
855	CASE ( 0 )
856	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
857	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
858	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
859	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
860	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
861	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
862	CASE ( 1 )
863	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
864	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
865	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
866	END SELECT
867	!
868	! ! Write Dirichlet lateral conditions
869	iihom = nlci - jpreci
870	!
871	SELECT CASE ( nbondi )
872	CASE ( -1 )
873	DO jl = 1, jpreci
874	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
875	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
876	END DO
877	CASE ( 0 )
878	DO jl = 1, jpreci
879	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
880	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
881	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
882	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
883	END DO
884	CASE ( 1 )
885	DO jl = 1, jpreci
886	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
887	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
888	END DO
889	END SELECT
890
891
892	! 3. North and south directions
893	! -----------------------------
894	! always closed : we play only with the neigbours
895	!
896	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
897	ijhom = nlcj - nrecj
898	DO jl = 1, jprecj
899	t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
900	t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
901	t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
902	t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
903	END DO
904	ENDIF
905	!
906	! ! Migrations
907	imigr = jprecj * jpi * jpk * 2
908	!
909	SELECT CASE ( nbondj )
910	CASE ( -1 )
911	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
912	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
913	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
914	CASE ( 0 )
915	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
916	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
917	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
918	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
919	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
920	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
921	CASE ( 1 )
922	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
923	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
924	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
925	END SELECT
926	!
927	! ! Write Dirichlet lateral conditions
928	ijhom = nlcj - jprecj
929	!
930	SELECT CASE ( nbondj )
931	CASE ( -1 )
932	DO jl = 1, jprecj
933	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
934	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
935	END DO
936	CASE ( 0 )
937	DO jl = 1, jprecj
938	ptab1(:,jl ,:) = t4sn(:,jl,:,1,2)
939	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
940	ptab2(:,jl ,:) = t4sn(:,jl,:,2,2)
941	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
942	END DO
943	CASE ( 1 )
944	DO jl = 1, jprecj
945	ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
946	ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
947	END DO
948	END SELECT
949
950
951	! 4. north fold treatment
952	! -----------------------
953	IF( npolj /= 0 ) THEN
954	!
955	SELECT CASE ( jpni )
956	CASE ( 1 )
957	CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs.
958	CALL lbc_nfd ( ptab2, cd_type2, psgn )
959	CASE DEFAULT
960	CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs.
961	CALL mpp_lbc_north (ptab2, cd_type2, psgn)
962	END SELECT
963	!
964	ENDIF
965	!
966	END SUBROUTINE mpp_lnk_3d_gather
967
968
969	SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
970	!!----------------------------------------------------------------------
971	!! * routine mpp_lnk_2d_e *
972	!!
973	!! ** Purpose : Message passing manadgement for 2d array (with halo)
974	!!
975	!! ** Method : Use mppsend and mpprecv function for passing mask
976	!! between processors following neighboring subdomains.
977	!! domain parameters
978	!! nlci : first dimension of the local subdomain
979	!! nlcj : second dimension of the local subdomain
980	!! jpr2di : number of rows for extra outer halo
981	!! jpr2dj : number of columns for extra outer halo
982	!! nbondi : mark for "east-west local boundary"
983	!! nbondj : mark for "north-south local boundary"
984	!! noea : number for local neighboring processors
985	!! nowe : number for local neighboring processors
986	!! noso : number for local neighboring processors
987	!! nono : number for local neighboring processors
988	!!
989	!!----------------------------------------------------------------------
990	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
991	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
992	! ! = T , U , V , F , W and I points
993	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the
994	!! ! north boundary, = 1. otherwise
995	INTEGER :: jl ! dummy loop indices
996	INTEGER :: imigr, iihom, ijhom ! temporary integers
997	INTEGER :: ipreci, iprecj ! temporary integers
998	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
999	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
1000	!!----------------------------------------------------------------------
1001
1002	ipreci = jpreci + jpr2di ! take into account outer extra 2D overlap area
1003	iprecj = jprecj + jpr2dj
1004
1005
1006	! 1. standard boundary treatment
1007	! ------------------------------
1008	! Order matters Here !!!!
1009	!
1010	! !* North-South boundaries (always colsed)
1011	IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jpr2dj : jprecj ) = 0.e0 ! south except at F-point
1012	pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0 ! north
1013
1014	! ! East-West boundaries
1015	! !* Cyclic east-west
1016	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1017	pt2d(1-jpr2di: 1 ,:) = pt2d(jpim1-jpr2di: jpim1 ,:) ! east
1018	pt2d( jpi :jpi+jpr2di,:) = pt2d( 2 :2+jpr2di,:) ! west
1019	!
1020	ELSE !* closed
1021	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpr2di :jpreci ,:) = 0.e0 ! south except at F-point
1022	pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0 ! north
1023	ENDIF
1024	!
1025
1026	! north fold treatment
1027	! -----------------------
1028	IF( npolj /= 0 ) THEN
1029	!
1030	SELECT CASE ( jpni )
1031	CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj )
1032	CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )
1033	END SELECT
1034	!
1035	ENDIF
1036
1037	! 2. East and west directions exchange
1038	! ------------------------------------
1039	! we play with the neigbours AND the row number because of the periodicity
1040	!
1041	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
1042	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
1043	iihom = nlci-nreci-jpr2di
1044	DO jl = 1, ipreci
1045	tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
1046	tr2we(:,jl,1) = pt2d(iihom +jl,:)
1047	END DO
1048	END SELECT
1049	!
1050	! ! Migrations
1051	imigr = ipreci * ( jpj + 2*jpr2dj)
1052	!
1053	SELECT CASE ( nbondi )
1054	CASE ( -1 )
1055	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
1056	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
1057	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1058	CASE ( 0 )
1059	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1060	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
1061	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
1062	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
1063	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1064	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1065	CASE ( 1 )
1066	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1067	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
1068	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1069	END SELECT
1070	!
1071	! ! Write Dirichlet lateral conditions
1072	iihom = nlci - jpreci
1073	!
1074	SELECT CASE ( nbondi )
1075	CASE ( -1 )
1076	DO jl = 1, ipreci
1077	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
1078	END DO
1079	CASE ( 0 )
1080	DO jl = 1, ipreci
1081	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1082	pt2d( iihom+jl,:) = tr2ew(:,jl,2)
1083	END DO
1084	CASE ( 1 )
1085	DO jl = 1, ipreci
1086	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1087	END DO
1088	END SELECT
1089
1090
1091	! 3. North and south directions
1092	! -----------------------------
1093	! always closed : we play only with the neigbours
1094	!
1095	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
1096	ijhom = nlcj-nrecj-jpr2dj
1097	DO jl = 1, iprecj
1098	tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
1099	tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
1100	END DO
1101	ENDIF
1102	!
1103	! ! Migrations
1104	imigr = iprecj * ( jpi + 2*jpr2di )
1105	!
1106	SELECT CASE ( nbondj )
1107	CASE ( -1 )
1108	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
1109	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
1110	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1111	CASE ( 0 )
1112	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1113	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
1114	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
1115	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
1116	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1117	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1118	CASE ( 1 )
1119	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1120	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
1121	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1122	END SELECT
1123	!
1124	! ! Write Dirichlet lateral conditions
1125	ijhom = nlcj - jprecj
1126	!
1127	SELECT CASE ( nbondj )
1128	CASE ( -1 )
1129	DO jl = 1, iprecj
1130	pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
1131	END DO
1132	CASE ( 0 )
1133	DO jl = 1, iprecj
1134	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1135	pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
1136	END DO
1137	CASE ( 1 )
1138	DO jl = 1, iprecj
1139	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1140	END DO
1141	END SELECT
1142
1143	END SUBROUTINE mpp_lnk_2d_e
1144
1145
1146	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1147	!!----------------------------------------------------------------------
1148	!! * routine mppsend *
1149	!!
1150	!! ** Purpose : Send message passing array
1151	!!
1152	!!----------------------------------------------------------------------
1153	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1154	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
1155	INTEGER , INTENT(in ) :: kdest ! receive process number
1156	INTEGER , INTENT(in ) :: ktyp ! tag of the message
1157	INTEGER , INTENT(in ) :: md_req ! argument for isend
1158	!!
1159	INTEGER :: iflag
1160	!!----------------------------------------------------------------------
1161	!
1162	SELECT CASE ( cn_mpi_send )
1163	CASE ( 'S' ) ! Standard mpi send (blocking)
1164	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
1165	CASE ( 'B' ) ! Buffer mpi send (blocking)
1166	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
1167	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
1168	! be carefull, one more argument here : the mpi request identifier..
1169	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1170	END SELECT
1171	!
1172	END SUBROUTINE mppsend
1173
1174
1175	SUBROUTINE mpprecv( ktyp, pmess, kbytes )
1176	!!----------------------------------------------------------------------
1177	!! * routine mpprecv *
1178	!!
1179	!! ** Purpose : Receive messag passing array
1180	!!
1181	!!----------------------------------------------------------------------
1182	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1183	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
1184	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
1185	!!
1186	INTEGER :: istatus(mpi_status_size)
1187	INTEGER :: iflag
1188	!!----------------------------------------------------------------------
1189	!
1190	CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag )
1191	!
1192	END SUBROUTINE mpprecv
1193
1194
1195	SUBROUTINE mppgather( ptab, kp, pio )
1196	!!----------------------------------------------------------------------
1197	!! * routine mppgather *
1198	!!
1199	!! ** Purpose : Transfert between a local subdomain array and a work
1200	!! array which is distributed following the vertical level.
1201	!!
1202	!!----------------------------------------------------------------------
1203	REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ptab ! subdomain input array
1204	INTEGER , INTENT(in ) :: kp ! record length
1205	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
1206	!!
1207	INTEGER :: itaille, ierror ! temporary integer
1208	!!---------------------------------------------------------------------
1209	!
1210	itaille = jpi * jpj
1211	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
1212	& mpi_double_precision, kp , mpi_comm_opa, ierror )
1213	!
1214	END SUBROUTINE mppgather
1215
1216
1217	SUBROUTINE mppscatter( pio, kp, ptab )
1218	!!----------------------------------------------------------------------
1219	!! * routine mppscatter *
1220	!!
1221	!! ** Purpose : Transfert between awork array which is distributed
1222	!! following the vertical level and the local subdomain array.
1223	!!
1224	!!----------------------------------------------------------------------
1225	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
1226	INTEGER :: kp ! Tag (not used with MPI
1227	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
1228	!!
1229	INTEGER :: itaille, ierror ! temporary integer
1230	!!---------------------------------------------------------------------
1231	!
1232	itaille=jpi*jpj
1233	!
1234	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
1235	& mpi_double_precision, kp , mpi_comm_opa, ierror )
1236	!
1237	END SUBROUTINE mppscatter
1238
1239
1240	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1241	!!----------------------------------------------------------------------
1242	!! * routine mppmax_a_int *
1243	!!
1244	!! ** Purpose : Find maximum value in an integer layout array
1245	!!
1246	!!----------------------------------------------------------------------
1247	INTEGER , INTENT(in ) :: kdim ! size of array
1248	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1249	INTEGER , INTENT(in ), OPTIONAL :: kcom !
1250	!!
1251	INTEGER :: ierror, localcomm ! temporary integer
1252	INTEGER, DIMENSION(kdim) :: iwork
1253	!!----------------------------------------------------------------------
1254	!
1255	localcomm = mpi_comm_opa
1256	IF( PRESENT(kcom) ) localcomm = kcom
1257	!
1258	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1259	!
1260	ktab(:) = iwork(:)
1261	!
1262	END SUBROUTINE mppmax_a_int
1263
1264
1265	SUBROUTINE mppmax_int( ktab, kcom )
1266	!!----------------------------------------------------------------------
1267	!! * routine mppmax_int *
1268	!!
1269	!! ** Purpose : Find maximum value in an integer layout array
1270	!!
1271	!!----------------------------------------------------------------------
1272	INTEGER, INTENT(inout) :: ktab ! ???
1273	INTEGER, INTENT(in ), OPTIONAL :: kcom ! ???
1274	!!
1275	INTEGER :: ierror, iwork, localcomm ! temporary integer
1276	!!----------------------------------------------------------------------
1277	!
1278	localcomm = mpi_comm_opa
1279	IF( PRESENT(kcom) ) localcomm = kcom
1280	!
1281	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1282	!
1283	ktab = iwork
1284	!
1285	END SUBROUTINE mppmax_int
1286
1287
1288	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1289	!!----------------------------------------------------------------------
1290	!! * routine mppmin_a_int *
1291	!!
1292	!! ** Purpose : Find minimum value in an integer layout array
1293	!!
1294	!!----------------------------------------------------------------------
1295	INTEGER , INTENT( in ) :: kdim ! size of array
1296	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1297	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
1298	!!
1299	INTEGER :: ierror, localcomm ! temporary integer
1300	INTEGER, DIMENSION(kdim) :: iwork
1301	!!----------------------------------------------------------------------
1302	!
1303	localcomm = mpi_comm_opa
1304	IF( PRESENT(kcom) ) localcomm = kcom
1305	!
1306	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1307	!
1308	ktab(:) = iwork(:)
1309	!
1310	END SUBROUTINE mppmin_a_int
1311
1312
1313	SUBROUTINE mppmin_int( ktab, kcom )
1314	!!----------------------------------------------------------------------
1315	!! * routine mppmin_int *
1316	!!
1317	!! ** Purpose : Find minimum value in an integer layout array
1318	!!
1319	!!----------------------------------------------------------------------
1320	INTEGER, INTENT(inout) :: ktab ! ???
1321	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
1322	!!
1323	INTEGER :: ierror, iwork, localcomm
1324	!!----------------------------------------------------------------------
1325	!
1326	localcomm = mpi_comm_opa
1327	IF( PRESENT(kcom) ) localcomm = kcom
1328	!
1329	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1330	!
1331	ktab = iwork
1332	!
1333	END SUBROUTINE mppmin_int
1334
1335
1336	SUBROUTINE mppsum_a_int( ktab, kdim )
1337	!!----------------------------------------------------------------------
1338	!! * routine mppsum_a_int *
1339	!!
1340	!! ** Purpose : Global integer sum, 1D array case
1341	!!
1342	!!----------------------------------------------------------------------
1343	INTEGER, INTENT(in ) :: kdim ! ???
1344	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
1345	!!
1346	INTEGER :: ierror
1347	INTEGER, DIMENSION (kdim) :: iwork
1348	!!----------------------------------------------------------------------
1349	!
1350	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1351	!
1352	ktab(:) = iwork(:)
1353	!
1354	END SUBROUTINE mppsum_a_int
1355
1356
1357	SUBROUTINE mppsum_int( ktab )
1358	!!----------------------------------------------------------------------
1359	!! * routine mppsum_int *
1360	!!
1361	!! ** Purpose : Global integer sum
1362	!!
1363	!!----------------------------------------------------------------------
1364	INTEGER, INTENT(inout) :: ktab
1365	!!
1366	INTEGER :: ierror, iwork
1367	!!----------------------------------------------------------------------
1368	!
1369	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1370	!
1371	ktab = iwork
1372	!
1373	END SUBROUTINE mppsum_int
1374
1375
1376	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1377	!!----------------------------------------------------------------------
1378	!! * routine mppmax_a_real *
1379	!!
1380	!! ** Purpose : Maximum
1381	!!
1382	!!----------------------------------------------------------------------
1383	INTEGER , INTENT(in ) :: kdim
1384	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
1385	INTEGER , INTENT(in ), OPTIONAL :: kcom
1386	!!
1387	INTEGER :: ierror, localcomm
1388	REAL(wp), DIMENSION(kdim) :: zwork
1389	!!----------------------------------------------------------------------
1390	!
1391	localcomm = mpi_comm_opa
1392	IF( PRESENT(kcom) ) localcomm = kcom
1393	!
1394	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1395	ptab(:) = zwork(:)
1396	!
1397	END SUBROUTINE mppmax_a_real
1398
1399
1400	SUBROUTINE mppmax_real( ptab, kcom )
1401	!!----------------------------------------------------------------------
1402	!! * routine mppmax_real *
1403	!!
1404	!! ** Purpose : Maximum
1405	!!
1406	!!----------------------------------------------------------------------
1407	REAL(wp), INTENT(inout) :: ptab ! ???
1408	INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???
1409	!!
1410	INTEGER :: ierror, localcomm
1411	REAL(wp) :: zwork
1412	!!----------------------------------------------------------------------
1413	!
1414	localcomm = mpi_comm_opa
1415	IF( PRESENT(kcom) ) localcomm = kcom
1416	!
1417	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1418	ptab = zwork
1419	!
1420	END SUBROUTINE mppmax_real
1421
1422
1423	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1424	!!----------------------------------------------------------------------
1425	!! * routine mppmin_a_real *
1426	!!
1427	!! ** Purpose : Minimum of REAL, array case
1428	!!
1429	!!-----------------------------------------------------------------------
1430	INTEGER , INTENT(in ) :: kdim
1431	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
1432	INTEGER , INTENT(in ), OPTIONAL :: kcom
1433	!!
1434	INTEGER :: ierror, localcomm
1435	REAL(wp), DIMENSION(kdim) :: zwork
1436	!!-----------------------------------------------------------------------
1437	!
1438	localcomm = mpi_comm_opa
1439	IF( PRESENT(kcom) ) localcomm = kcom
1440	!
1441	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1442	ptab(:) = zwork(:)
1443	!
1444	END SUBROUTINE mppmin_a_real
1445
1446
1447	SUBROUTINE mppmin_real( ptab, kcom )
1448	!!----------------------------------------------------------------------
1449	!! * routine mppmin_real *
1450	!!
1451	!! ** Purpose : minimum of REAL, scalar case
1452	!!
1453	!!-----------------------------------------------------------------------
1454	REAL(wp), INTENT(inout) :: ptab !
1455	INTEGER , INTENT(in ), OPTIONAL :: kcom
1456	!!
1457	INTEGER :: ierror
1458	REAL(wp) :: zwork
1459	INTEGER :: localcomm
1460	!!-----------------------------------------------------------------------
1461	!
1462	localcomm = mpi_comm_opa
1463	IF( PRESENT(kcom) ) localcomm = kcom
1464	!
1465	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1466	ptab = zwork
1467	!
1468	END SUBROUTINE mppmin_real
1469
1470
1471	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1472	!!----------------------------------------------------------------------
1473	!! * routine mppsum_a_real *
1474	!!
1475	!! ** Purpose : global sum, REAL ARRAY argument case
1476	!!
1477	!!-----------------------------------------------------------------------
1478	INTEGER , INTENT( in ) :: kdim ! size of ptab
1479	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
1480	INTEGER , INTENT( in ), OPTIONAL :: kcom
1481	!!
1482	INTEGER :: ierror ! temporary integer
1483	INTEGER :: localcomm
1484	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
1485	!!-----------------------------------------------------------------------
1486	!
1487	localcomm = mpi_comm_opa
1488	IF( PRESENT(kcom) ) localcomm = kcom
1489	!
1490	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1491	ptab(:) = zwork(:)
1492	!
1493	END SUBROUTINE mppsum_a_real
1494
1495
1496	SUBROUTINE mppsum_real( ptab, kcom )
1497	!!----------------------------------------------------------------------
1498	!! * routine mppsum_real *
1499	!!
1500	!! ** Purpose : global sum, SCALAR argument case
1501	!!
1502	!!-----------------------------------------------------------------------
1503	REAL(wp), INTENT(inout) :: ptab ! input scalar
1504	INTEGER , INTENT(in ), OPTIONAL :: kcom
1505	!!
1506	INTEGER :: ierror, localcomm
1507	REAL(wp) :: zwork
1508	!!-----------------------------------------------------------------------
1509	!
1510	localcomm = mpi_comm_opa
1511	IF( PRESENT(kcom) ) localcomm = kcom
1512	!
1513	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1514	ptab = zwork
1515	!
1516	END SUBROUTINE mppsum_real
1517
1518	# if defined key_mpp_rep
1519	SUBROUTINE mppsum_realdd( ytab, kcom )
1520	!!----------------------------------------------------------------------
1521	!! * routine mppsum_realdd *
1522	!!
1523	!! ** Purpose : global sum in Massively Parallel Processing
1524	!! SCALAR argument case for double-double precision
1525	!!
1526	!!-----------------------------------------------------------------------
1527	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
1528	INTEGER , INTENT( in ), OPTIONAL :: kcom
1529
1530	!! * Local variables (MPI version)
1531	INTEGER :: ierror
1532	INTEGER :: localcomm
1533	COMPLEX(wp) :: zwork
1534
1535	localcomm = mpi_comm_opa
1536	IF( PRESENT(kcom) ) localcomm = kcom
1537
1538	! reduce local sums into global sum
1539	CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, &
1540	MPI_SUMDD,localcomm,ierror)
1541	ytab = zwork
1542
1543	END SUBROUTINE mppsum_realdd
1544
1545
1546	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
1547	!!----------------------------------------------------------------------
1548	!! * routine mppsum_a_realdd *
1549	!!
1550	!! ** Purpose : global sum in Massively Parallel Processing
1551	!! COMPLEX ARRAY case for double-double precision
1552	!!
1553	!!-----------------------------------------------------------------------
1554	INTEGER , INTENT( in ) :: kdim ! size of ytab
1555	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
1556	INTEGER , INTENT( in ), OPTIONAL :: kcom
1557
1558	!! * Local variables (MPI version)
1559	INTEGER :: ierror ! temporary integer
1560	INTEGER :: localcomm
1561	COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace
1562
1563	localcomm = mpi_comm_opa
1564	IF( PRESENT(kcom) ) localcomm = kcom
1565
1566	CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, &
1567	MPI_SUMDD,localcomm,ierror)
1568	ytab(:) = zwork(:)
1569
1570	END SUBROUTINE mppsum_a_realdd
1571	# endif
1572
1573	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1574	!!------------------------------------------------------------------------
1575	!! * routine mpp_minloc *
1576	!!
1577	!! ** Purpose : Compute the global minimum of an array ptab
1578	!! and also give its global position
1579	!!
1580	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1581	!!
1582	!!--------------------------------------------------------------------------
1583	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
1584	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
1585	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
1586	INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame
1587	!!
1588	INTEGER , DIMENSION(2) :: ilocs
1589	INTEGER :: ierror
1590	REAL(wp) :: zmin ! local minimum
1591	REAL(wp), DIMENSION(2,1) :: zain, zaout
1592	!!-----------------------------------------------------------------------
1593	!
1594	zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
1595	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
1596	!
1597	ki = ilocs(1) + nimpp - 1
1598	kj = ilocs(2) + njmpp - 1
1599	!
1600	zain(1,:)=zmin
1601	zain(2,:)=ki+10000.*kj
1602	!
1603	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1604	!
1605	pmin = zaout(1,1)
1606	kj = INT(zaout(2,1)/10000.)
1607	ki = INT(zaout(2,1) - 10000.*kj )
1608	!
1609	END SUBROUTINE mpp_minloc2d
1610
1611
1612	SUBROUTINE mpp_minloc3d( ptab3d, pmask3d, pmin, ki, kj ,kk)
1613	!!------------------------------------------------------------------------
1614	!! * routine mpp_minloc *
1615	!!
1616	!! ** Purpose : Compute the global minimum of an array ptab
1617	!! and also give its global position
1618	!!
1619	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1620	!!
1621	!!--------------------------------------------------------------------------
1622	!FTRANS ptab3d :I :I :z
1623	!FTRANS pmask3d :I :I :z
1624	!! DCSE_NEMO: work around a deficiency in ftrans
1625	! REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab3d ! Local 3D array
1626	! REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask3d ! Local mask
1627	REAL(wp), INTENT(in ) :: ptab3d(jpi,jpj,jpk)
1628	REAL(wp), INTENT(in ) :: pmask3d(jpi,jpj,jpk)
1629	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
1630	INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame
1631	!!
1632	INTEGER :: ierror
1633	REAL(wp) :: zmin ! local minimum
1634	INTEGER , DIMENSION(3) :: ilocs
1635	REAL(wp), DIMENSION(2,1) :: zain, zaout
1636	!!-----------------------------------------------------------------------
1637	!
1638	zmin = MINVAL( ptab3d(:,:,:) , mask= pmask3d == 1.e0 )
1639	ilocs = MINLOC( ptab3d(:,:,:) , mask= pmask3d == 1.e0 )
1640	!
1641	!! DCSE_NEMO: Attention!
1642	#if defined key_z_first
1643	ki = ilocs(2) + nimpp - 1
1644	kj = ilocs(3) + njmpp - 1
1645	kk = ilocs(1)
1646	#else
1647	ki = ilocs(1) + nimpp - 1
1648	kj = ilocs(2) + njmpp - 1
1649	kk = ilocs(3)
1650	#endif
1651	!
1652	zain(1,:)=zmin
1653	zain(2,:)=ki+10000.kj+100000000.kk
1654	!
1655	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1656	!
1657	pmin = zaout(1,1)
1658	kk = INT( zaout(2,1) / 100000000. )
1659	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
1660	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1661	!
1662	END SUBROUTINE mpp_minloc3d
1663
1664
1665	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1666	!!------------------------------------------------------------------------
1667	!! * routine mpp_maxloc *
1668	!!
1669	!! ** Purpose : Compute the global maximum of an array ptab
1670	!! and also give its global position
1671	!!
1672	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1673	!!
1674	!!--------------------------------------------------------------------------
1675	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
1676	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
1677	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
1678	INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame
1679	!!
1680	INTEGER :: ierror
1681	INTEGER, DIMENSION (2) :: ilocs
1682	REAL(wp) :: zmax ! local maximum
1683	REAL(wp), DIMENSION(2,1) :: zain, zaout
1684	!!-----------------------------------------------------------------------
1685	!
1686	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
1687	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
1688	!
1689	ki = ilocs(1) + nimpp - 1
1690	kj = ilocs(2) + njmpp - 1
1691	!
1692	zain(1,:) = zmax
1693	zain(2,:) = ki + 10000. * kj
1694	!
1695	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1696	!
1697	pmax = zaout(1,1)
1698	kj = INT( zaout(2,1) / 10000. )
1699	ki = INT( zaout(2,1) - 10000.* kj )
1700	!
1701	END SUBROUTINE mpp_maxloc2d
1702
1703
1704	SUBROUTINE mpp_maxloc3d( ptab3d, pmask3d, pmax, ki, kj, kk )
1705	!!------------------------------------------------------------------------
1706	!! * routine mpp_maxloc *
1707	!!
1708	!! ** Purpose : Compute the global maximum of an array ptab
1709	!! and also give its global position
1710	!!
1711	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1712	!!
1713	!!--------------------------------------------------------------------------
1714	!FTRANS ptab3d :I :I :z
1715	!FTRANS pmask3d :I :I :z
1716	!! DCSE_NEMO: work around a deficiency in ftrans
1717	! REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab3d ! Local 2D array
1718	! REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask3d ! Local mask
1719	REAL(wp), INTENT(in ) :: ptab3d(jpi,jpj,jpk) ! Local 2D array
1720	REAL(wp), INTENT(in ) :: pmask3d(jpi,jpj,jpk) ! Local mask
1721	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
1722	INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame
1723	!!
1724	REAL(wp) :: zmax ! local maximum
1725	REAL(wp), DIMENSION(2,1) :: zain, zaout
1726	INTEGER , DIMENSION(3) :: ilocs
1727	INTEGER :: ierror
1728	!!-----------------------------------------------------------------------
1729	!
1730	zmax = MAXVAL( ptab3d(:,:,:) , mask= pmask3d == 1.e0 )
1731	ilocs = MAXLOC( ptab3d(:,:,:) , mask= pmask3d == 1.e0 )
1732	!
1733	!! DCSE_NEMO: Attention!
1734	#if defined key_z_first
1735	ki = ilocs(2) + nimpp - 1
1736	kj = ilocs(3) + njmpp - 1
1737	kk = ilocs(1)
1738	#else
1739	ki = ilocs(1) + nimpp - 1
1740	kj = ilocs(2) + njmpp - 1
1741	kk = ilocs(3)
1742	#endif
1743	!
1744	zain(1,:)=zmax
1745	zain(2,:)=ki+10000.kj+100000000.kk
1746	!
1747	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1748	!
1749	pmax = zaout(1,1)
1750	kk = INT( zaout(2,1) / 100000000. )
1751	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
1752	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1753	!
1754	END SUBROUTINE mpp_maxloc3d
1755
1756
1757	SUBROUTINE mppsync()
1758	!!----------------------------------------------------------------------
1759	!! * routine mppsync *
1760	!!
1761	!! ** Purpose : Massively parallel processors, synchroneous
1762	!!
1763	!!-----------------------------------------------------------------------
1764	INTEGER :: ierror
1765	!!-----------------------------------------------------------------------
1766	!
1767	CALL mpi_barrier( mpi_comm_opa, ierror )
1768	!
1769	END SUBROUTINE mppsync
1770
1771
1772	SUBROUTINE mppstop
1773	!!----------------------------------------------------------------------
1774	!! * routine mppstop *
1775	!!
1776	!! ** purpose : Stop massilively parallel processors method
1777	!!
1778	!!----------------------------------------------------------------------
1779	INTEGER :: info
1780	!!----------------------------------------------------------------------
1781	!
1782	CALL mppsync
1783	CALL mpi_finalize( info )
1784	!
1785	END SUBROUTINE mppstop
1786
1787
1788	SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout)
1789	!!----------------------------------------------------------------------
1790	!! * routine mppobc *
1791	!!
1792	!! ** Purpose : Message passing management for open boundary
1793	!! conditions array
1794	!!
1795	!! ** Method : Use mppsend and mpprecv function for passing mask
1796	!! between processors following neighboring subdomains.
1797	!! domain parameters
1798	!! nlci : first dimension of the local subdomain
1799	!! nlcj : second dimension of the local subdomain
1800	!! nbondi : mark for "east-west local boundary"
1801	!! nbondj : mark for "north-south local boundary"
1802	!! noea : number for local neighboring processors
1803	!! nowe : number for local neighboring processors
1804	!! noso : number for local neighboring processors
1805	!! nono : number for local neighboring processors
1806	!!
1807	!!----------------------------------------------------------------------
1808	USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
1809	!! DCSE_NEMO: Warning! ztab is also a lib_mpp module variable
1810	! USE wrk_nemo, ONLY: ztab => wrk_2d_1
1811	USE wrk_nemo, ONLY: ztab2d => wrk_2d_1
1812	!
1813	INTEGER , INTENT(in ) :: kd1, kd2 ! starting and ending indices
1814	INTEGER , INTENT(in ) :: kl ! index of open boundary
1815	INTEGER , INTENT(in ) :: kk ! vertical dimension
1816	INTEGER , INTENT(in ) :: ktype ! define north/south or east/west cdt
1817	! ! = 1 north/south ; = 2 east/west
1818	INTEGER , INTENT(in ) :: kij ! horizontal dimension
1819	INTEGER , INTENT(in ) :: kumout ! ocean.output logical unit
1820	REAL(wp), INTENT(inout), DIMENSION(kij,kk) :: ptab ! variable array
1821	!
1822	INTEGER :: ji, jj, jk, jl ! dummy loop indices
1823	INTEGER :: iipt0, iipt1, ilpt1 ! local integers
1824	INTEGER :: ijpt0, ijpt1 ! - -
1825	INTEGER :: imigr, iihom, ijhom ! - -
1826	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1827	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
1828	!!----------------------------------------------------------------------
1829
1830	IF( wrk_in_use(2, 1) ) THEN
1831	WRITE(kumout, cform_err)
1832	WRITE(kumout,*) 'mppobc : requested workspace array unavailable'
1833	CALL mppstop
1834	ENDIF
1835
1836	! boundary condition initialization
1837	! ---------------------------------
1838	ztab2d(:,:) = 0.e0
1839	!
1840	IF( ktype==1 ) THEN ! north/south boundaries
1841	iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )
1842	iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
1843	ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )
1844	ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )
1845	ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )
1846	ELSEIF( ktype==2 ) THEN ! east/west boundaries
1847	iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )
1848	iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )
1849	ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )
1850	ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
1851	ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )
1852	ELSE
1853	WRITE(kumout, cform_err)
1854	WRITE(kumout,*) 'mppobc : bad ktype'
1855	CALL mppstop
1856	ENDIF
1857
1858	! Communication level by level
1859	! ----------------------------
1860	!!gm Remark : this is very time consumming!!!
1861	! ! ------------------------ !
1862	DO jk = 1, kk ! Loop over the levels !
1863	! ! ------------------------ !
1864	!
1865	IF( ktype == 1 ) THEN ! north/south boundaries
1866	DO jj = ijpt0, ijpt1
1867	DO ji = iipt0, iipt1
1868	ztab2d(ji,jj) = ptab(ji,jk)
1869	END DO
1870	END DO
1871	ELSEIF( ktype == 2 ) THEN ! east/west boundaries
1872	DO jj = ijpt0, ijpt1
1873	DO ji = iipt0, iipt1
1874	ztab2d(ji,jj) = ptab(jj,jk)
1875	END DO
1876	END DO
1877	ENDIF
1878
1879
1880	! 1. East and west directions
1881	! ---------------------------
1882	!
1883	IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions
1884	iihom = nlci-nreci
1885	DO jl = 1, jpreci
1886	t2ew(:,jl,1) = ztab2d(jpreci+jl,:)
1887	t2we(:,jl,1) = ztab2d(iihom +jl,:)
1888	END DO
1889	ENDIF
1890	!
1891	! ! Migrations
1892	imigr=jpreci*jpj
1893	!
1894	IF( nbondi == -1 ) THEN
1895	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1896	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1897	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1898	ELSEIF( nbondi == 0 ) THEN
1899	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1900	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1901	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1902	CALL mpprecv( 2, t2we(1,1,2), imigr )
1903	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1904	IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )
1905	ELSEIF( nbondi == 1 ) THEN
1906	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1907	CALL mpprecv( 2, t2we(1,1,2), imigr )
1908	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1909	ENDIF
1910	!
1911	! ! Write Dirichlet lateral conditions
1912	iihom = nlci-jpreci
1913	!
1914	IF( nbondi == 0 .OR. nbondi == 1 ) THEN
1915	DO jl = 1, jpreci
1916	ztab2d(jl,:) = t2we(:,jl,2)
1917	END DO
1918	ENDIF
1919	IF( nbondi == -1 .OR. nbondi == 0 ) THEN
1920	DO jl = 1, jpreci
1921	ztab2d(iihom+jl,:) = t2ew(:,jl,2)
1922	END DO
1923	ENDIF
1924
1925
1926	! 2. North and south directions
1927	! -----------------------------
1928	!
1929	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
1930	ijhom = nlcj-nrecj
1931	DO jl = 1, jprecj
1932	t2sn(:,jl,1) = ztab2d(:,ijhom +jl)
1933	t2ns(:,jl,1) = ztab2d(:,jprecj+jl)
1934	END DO
1935	ENDIF
1936	!
1937	! ! Migrations
1938	imigr = jprecj * jpi
1939	!
1940	IF( nbondj == -1 ) THEN
1941	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1942	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1943	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1944	ELSEIF( nbondj == 0 ) THEN
1945	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1946	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1947	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1948	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1949	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1950	IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
1951	ELSEIF( nbondj == 1 ) THEN
1952	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1953	CALL mpprecv( 4, t2sn(1,1,2), imigr)
1954	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1955	ENDIF
1956	!
1957	! ! Write Dirichlet lateral conditions
1958	ijhom = nlcj - jprecj
1959	IF( nbondj == 0 .OR. nbondj == 1 ) THEN
1960	DO jl = 1, jprecj
1961	ztab2d(:,jl) = t2sn(:,jl,2)
1962	END DO
1963	ENDIF
1964	IF( nbondj == 0 .OR. nbondj == -1 ) THEN
1965	DO jl = 1, jprecj
1966	ztab2d(:,ijhom+jl) = t2ns(:,jl,2)
1967	END DO
1968	ENDIF
1969	IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
1970	DO jj = ijpt0, ijpt1 ! north/south boundaries
1971	DO ji = iipt0,ilpt1
1972	ptab(ji,jk) = ztab2d(ji,jj)
1973	END DO
1974	END DO
1975	ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
1976	DO jj = ijpt0, ilpt1 ! east/west boundaries
1977	DO ji = iipt0,iipt1
1978	ptab(jj,jk) = ztab2d(ji,jj)
1979	END DO
1980	END DO
1981	ENDIF
1982	!
1983	END DO
1984	!
1985	IF( wrk_not_released(2, 1) ) THEN
1986	WRITE(kumout, cform_err)
1987	WRITE(kumout,*) 'mppobc : failed to release workspace array'
1988	CALL mppstop
1989	ENDIF
1990	!
1991	END SUBROUTINE mppobc
1992
1993
1994	SUBROUTINE mpp_comm_free( kcom )
1995	!!----------------------------------------------------------------------
1996	!!----------------------------------------------------------------------
1997	INTEGER, INTENT(in) :: kcom
1998	!!
1999	INTEGER :: ierr
2000	!!----------------------------------------------------------------------
2001	!
2002	CALL MPI_COMM_FREE(kcom, ierr)
2003	!
2004	END SUBROUTINE mpp_comm_free
2005
2006
2007	SUBROUTINE mpp_ini_ice( pindic, kumout )
2008	!!----------------------------------------------------------------------
2009	!! * routine mpp_ini_ice *
2010	!!
2011	!! ** Purpose : Initialize special communicator for ice areas
2012	!! condition together with global variables needed in the ddmpp folding
2013	!!
2014	!! ** Method : - Look for ice processors in ice routines
2015	!! - Put their number in nrank_ice
2016	!! - Create groups for the world processors and the ice processors
2017	!! - Create a communicator for ice processors
2018	!!
2019	!! ** output
2020	!! njmppmax = njmpp for northern procs
2021	!! ndim_rank_ice = number of processors with ice
2022	!! nrank_ice (ndim_rank_ice) = ice processors
2023	!! ngrp_world = group ID for the world processors
2024	!! ngrp_ice = group ID for the ice processors
2025	!! ncomm_ice = communicator for the ice procs.
2026	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
2027	!!
2028	!!----------------------------------------------------------------------
2029	INTEGER, INTENT(in) :: pindic
2030	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
2031	!!
2032	INTEGER :: jjproc
2033	INTEGER :: ii, ierr
2034	INTEGER, ALLOCATABLE, DIMENSION(:) :: kice
2035	INTEGER, ALLOCATABLE, DIMENSION(:) :: zwork
2036	!!----------------------------------------------------------------------
2037	!
2038	! Since this is just an init routine and these arrays are of length jpnij
2039	! then don't use wrk_nemo module - just allocate and deallocate.
2040	ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
2041	IF( ierr /= 0 ) THEN
2042	WRITE(kumout, cform_err)
2043	WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
2044	CALL mppstop
2045	ENDIF
2046
2047	! Look for how many procs with sea-ice
2048	!
2049	kice = 0
2050	DO jjproc = 1, jpnij
2051	IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1
2052	END DO
2053	!
2054	zwork = 0
2055	CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
2056	ndim_rank_ice = SUM( zwork )
2057
2058	! Allocate the right size to nrank_north
2059	IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice )
2060	ALLOCATE( nrank_ice(ndim_rank_ice) )
2061	!
2062	ii = 0
2063	nrank_ice = 0
2064	DO jjproc = 1, jpnij
2065	IF( zwork(jjproc) == 1) THEN
2066	ii = ii + 1
2067	nrank_ice(ii) = jjproc -1
2068	ENDIF
2069	END DO
2070
2071	! Create the world group
2072	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2073
2074	! Create the ice group from the world group
2075	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2076
2077	! Create the ice communicator , ie the pool of procs with sea-ice
2078	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2079
2080	! Find proc number in the world of proc 0 in the north
2081	! The following line seems to be useless, we just comment & keep it as reminder
2082	! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
2083	!
2084	DEALLOCATE(kice, zwork)
2085	!
2086	END SUBROUTINE mpp_ini_ice
2087
2088
2089	SUBROUTINE mpp_ini_znl( kumout )
2090	!!----------------------------------------------------------------------
2091	!! * routine mpp_ini_znl *
2092	!!
2093	!! ** Purpose : Initialize special communicator for computing zonal sum
2094	!!
2095	!! ** Method : - Look for processors in the same row
2096	!! - Put their number in nrank_znl
2097	!! - Create group for the znl processors
2098	!! - Create a communicator for znl processors
2099	!! - Determine if processor should write znl files
2100	!!
2101	!! ** output
2102	!! ndim_rank_znl = number of processors on the same row
2103	!! ngrp_znl = group ID for the znl processors
2104	!! ncomm_znl = communicator for the ice procs.
2105	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
2106	!!
2107	!!----------------------------------------------------------------------
2108	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
2109	!
2110	INTEGER :: jproc ! dummy loop integer
2111	INTEGER :: ierr, ii ! local integer
2112	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
2113	!!----------------------------------------------------------------------
2114	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
2115	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2116	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa : ', mpi_comm_opa
2117	!
2118	ALLOCATE( kwork(jpnij), STAT=ierr )
2119	IF( ierr /= 0 ) THEN
2120	WRITE(kumout, cform_err)
2121	WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2122	CALL mppstop
2123	ENDIF
2124
2125	IF( jpnj == 1 ) THEN
2126	ngrp_znl = ngrp_world
2127	ncomm_znl = mpi_comm_opa
2128	ELSE
2129	!
2130	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2131	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2132	!-$$ CALL flush(numout)
2133	!
2134	! Count number of processors on the same row
2135	ndim_rank_znl = 0
2136	DO jproc=1,jpnij
2137	IF ( kwork(jproc) == njmpp ) THEN
2138	ndim_rank_znl = ndim_rank_znl + 1
2139	ENDIF
2140	END DO
2141	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2142	!-$$ CALL flush(numout)
2143	! Allocate the right size to nrank_znl
2144	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2145	ALLOCATE(nrank_znl(ndim_rank_znl))
2146	ii = 0
2147	nrank_znl (:) = 0
2148	DO jproc=1,jpnij
2149	IF ( kwork(jproc) == njmpp) THEN
2150	ii = ii + 1
2151	nrank_znl(ii) = jproc -1
2152	ENDIF
2153	END DO
2154	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2155	!-$$ CALL flush(numout)
2156
2157	! Create the opa group
2158	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2159	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2160	!-$$ CALL flush(numout)
2161
2162	! Create the znl group from the opa group
2163	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2164	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2165	!-$$ CALL flush(numout)
2166
2167	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2168	CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2169	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2170	!-$$ CALL flush(numout)
2171	!
2172	END IF
2173
2174	! Determines if processor if the first (starting from i=1) on the row
2175	IF ( jpni == 1 ) THEN
2176	l_znl_root = .TRUE.
2177	ELSE
2178	l_znl_root = .FALSE.
2179	kwork (1) = nimpp
2180	CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2181	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2182	END IF
2183
2184	DEALLOCATE(kwork)
2185
2186	END SUBROUTINE mpp_ini_znl
2187
2188
2189	SUBROUTINE mpp_ini_north
2190	!!----------------------------------------------------------------------
2191	!! * routine mpp_ini_north *
2192	!!
2193	!! ** Purpose : Initialize special communicator for north folding
2194	!! condition together with global variables needed in the mpp folding
2195	!!
2196	!! ** Method : - Look for northern processors
2197	!! - Put their number in nrank_north
2198	!! - Create groups for the world processors and the north processors
2199	!! - Create a communicator for northern processors
2200	!!
2201	!! ** output
2202	!! njmppmax = njmpp for northern procs
2203	!! ndim_rank_north = number of processors in the northern line
2204	!! nrank_north (ndim_rank_north) = number of the northern procs.
2205	!! ngrp_world = group ID for the world processors
2206	!! ngrp_north = group ID for the northern processors
2207	!! ncomm_north = communicator for the northern procs.
2208	!! north_root = number (in the world) of proc 0 in the northern comm.
2209	!!
2210	!!----------------------------------------------------------------------
2211	INTEGER :: ierr
2212	INTEGER :: jjproc
2213	INTEGER :: ii, ji
2214	!!----------------------------------------------------------------------
2215	!
2216	njmppmax = MAXVAL( njmppt )
2217	!
2218	! Look for how many procs on the northern boundary
2219	ndim_rank_north = 0
2220	DO jjproc = 1, jpnij
2221	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
2222	END DO
2223	!
2224	! Allocate the right size to nrank_north
2225	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2226	ALLOCATE( nrank_north(ndim_rank_north) )
2227
2228	! Fill the nrank_north array with proc. number of northern procs.
2229	! Note : the rank start at 0 in MPI
2230	ii = 0
2231	DO ji = 1, jpnij
2232	IF ( njmppt(ji) == njmppmax ) THEN
2233	ii=ii+1
2234	nrank_north(ii)=ji-1
2235	END IF
2236	END DO
2237	!
2238	! create the world group
2239	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2240	!
2241	! Create the North group from the world group
2242	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2243	!
2244	! Create the North communicator , ie the pool of procs in the north group
2245	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2246	!
2247	END SUBROUTINE mpp_ini_north
2248
2249
2250	SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2251	!!---------------------------------------------------------------------
2252	!! * routine mpp_lbc_north_3d *
2253	!!
2254	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2255	!! in mpp configuration in case of jpn1 > 1
2256	!!
2257	!! ** Method : North fold condition and mpp with more than one proc
2258	!! in i-direction require a specific treatment. We gather
2259	!! the 4 northern lines of the global domain on 1 processor
2260	!! and apply lbc north-fold on this sub array. Then we
2261	!! scatter the north fold array back to the processors.
2262	!!
2263	!!----------------------------------------------------------------------
2264	!FTRANS pt3d :I :I :z
2265	!! DCSE_NEMO: work around a deficiency in ftrans
2266	! REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied
2267	REAL(wp), INTENT(inout) :: pt3d(jpi,jpj,jpk)
2268	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
2269	! ! = T , U , V , F or W gridpoints
2270	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
2271	!! ! = 1. , the sign is kept
2272	INTEGER :: ji, jj, jr
2273	INTEGER :: ierr, itaille, ildi, ilei, iilb
2274	INTEGER :: ijpj, ijpjm1, ij, iproc
2275	!!----------------------------------------------------------------------
2276	!
2277	ijpj = 4
2278	ijpjm1 = 3
2279	ztab(:,:,:) = 0.e0
2280	!
2281	DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d
2282	ij = jj - nlcj + ijpj
2283	znorthloc(:,ij,:) = pt3d(:,jj,:)
2284	END DO
2285	!
2286	! ! Build in procs of ncomm_north the znorthgloio
2287	itaille = jpi * jpk * ijpj
2288	CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &
2289	& znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2290	!
2291	! ! recover the global north array
2292	DO jr = 1, ndim_rank_north
2293	iproc = nrank_north(jr) + 1
2294	ildi = nldit (iproc)
2295	ilei = nleit (iproc)
2296	iilb = nimppt(iproc)
2297	DO jj = 1, 4
2298	DO ji = ildi, ilei
2299	ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
2300	END DO
2301	END DO
2302	END DO
2303	!
2304	CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
2305	!
2306	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
2307	ij = jj - nlcj + ijpj
2308	DO ji= 1, nlci
2309	pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)
2310	END DO
2311	END DO
2312	!
2313	END SUBROUTINE mpp_lbc_north_3d
2314
2315
2316	SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2317	!!---------------------------------------------------------------------
2318	!! * routine mpp_lbc_north_2d *
2319	!!
2320	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2321	!! in mpp configuration in case of jpn1 > 1 (for 2d array )
2322	!!
2323	!! ** Method : North fold condition and mpp with more than one proc
2324	!! in i-direction require a specific treatment. We gather
2325	!! the 4 northern lines of the global domain on 1 processor
2326	!! and apply lbc north-fold on this sub array. Then we
2327	!! scatter the north fold array back to the processors.
2328	!!
2329	!!----------------------------------------------------------------------
2330	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the b.c. is applied
2331	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
2332	! ! = T , U , V , F or W gridpoints
2333	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
2334	!! ! = 1. , the sign is kept
2335	INTEGER :: ji, jj, jr
2336	INTEGER :: ierr, itaille, ildi, ilei, iilb
2337	INTEGER :: ijpj, ijpjm1, ij, iproc
2338	!!----------------------------------------------------------------------
2339	!
2340	ijpj = 4
2341	ijpjm1 = 3
2342	ztab_2d(:,:) = 0.e0
2343	!
2344	DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc_2d the last 4 jlines of pt2d
2345	ij = jj - nlcj + ijpj
2346	znorthloc_2d(:,ij) = pt2d(:,jj)
2347	END DO
2348
2349	! ! Build in procs of ncomm_north the znorthgloio_2d
2350	itaille = jpi * ijpj
2351	CALL MPI_ALLGATHER( znorthloc_2d , itaille, MPI_DOUBLE_PRECISION, &
2352	& znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2353	!
2354	DO jr = 1, ndim_rank_north ! recover the global north array
2355	iproc = nrank_north(jr) + 1
2356	ildi=nldit (iproc)
2357	ilei=nleit (iproc)
2358	iilb=nimppt(iproc)
2359	DO jj = 1, 4
2360	DO ji = ildi, ilei
2361	ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr)
2362	END DO
2363	END DO
2364	END DO
2365	!
2366	CALL lbc_nfd( ztab_2d, cd_type, psgn ) ! North fold boundary condition
2367	!
2368	!
2369	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
2370	ij = jj - nlcj + ijpj
2371	DO ji = 1, nlci
2372	pt2d(ji,jj) = ztab_2d(ji+nimpp-1,ij)
2373	END DO
2374	END DO
2375	!
2376	END SUBROUTINE mpp_lbc_north_2d
2377
2378
2379	SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2380	!!---------------------------------------------------------------------
2381	!! * routine mpp_lbc_north_2d *
2382	!!
2383	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2384	!! in mpp configuration in case of jpn1 > 1 and for 2d
2385	!! array with outer extra halo
2386	!!
2387	!! ** Method : North fold condition and mpp with more than one proc
2388	!! in i-direction require a specific treatment. We gather
2389	!! the 4+2*jpr2dj northern lines of the global domain on 1
2390	!! processor and apply lbc north-fold on this sub array.
2391	!! Then we scatter the north fold array back to the processors.
2392	!!
2393	!!----------------------------------------------------------------------
2394	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
2395	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
2396	! ! = T , U , V , F or W -points
2397	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
2398	!! ! north fold, = 1. otherwise
2399	INTEGER :: ji, jj, jr
2400	INTEGER :: ierr, itaille, ildi, ilei, iilb
2401	INTEGER :: ijpj, ij, iproc
2402	!!----------------------------------------------------------------------
2403	!
2404	ijpj=4
2405	ztab_e(:,:) = 0.e0
2406
2407	ij=0
2408	! put in znorthloc_e the last 4 jlines of pt2d
2409	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2410	ij = ij + 1
2411	DO ji = 1, jpi
2412	znorthloc_e(ji,ij)=pt2d(ji,jj)
2413	END DO
2414	END DO
2415	!
2416	itaille = jpi * ( ijpj + 2 * jpr2dj )
2417	CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
2418	& znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2419	!
2420	DO jr = 1, ndim_rank_north ! recover the global north array
2421	iproc = nrank_north(jr) + 1
2422	ildi = nldit (iproc)
2423	ilei = nleit (iproc)
2424	iilb = nimppt(iproc)
2425	DO jj = 1, ijpj+2*jpr2dj
2426	DO ji = ildi, ilei
2427	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2428	END DO
2429	END DO
2430	END DO
2431
2432
2433	! 2. North-Fold boundary conditions
2434	! ----------------------------------
2435	CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
2436
2437	ij = jpr2dj
2438	!! Scatter back to pt2d
2439	DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2440	ij = ij +1
2441	DO ji= 1, nlci
2442	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2443	END DO
2444	END DO
2445	!
2446	END SUBROUTINE mpp_lbc_north_e
2447
2448
2449	SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
2450	!!---------------------------------------------------------------------
2451	!! * routine mpp_init.opa *
2452	!!
2453	!! ** Purpose :: export and attach a MPI buffer for bsend
2454	!!
2455	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
2456	!! but classical mpi_init
2457	!!
2458	!! History :: 01/11 :: IDRIS initial version for IBM only
2459	!! 08/04 :: R. Benshila, generalisation
2460	!!---------------------------------------------------------------------
2461	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
2462	INTEGER , INTENT(inout) :: ksft
2463	INTEGER , INTENT( out) :: code
2464	INTEGER :: ierr, ji
2465	LOGICAL :: mpi_was_called
2466	!!---------------------------------------------------------------------
2467	!
2468	CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization
2469	IF ( code /= MPI_SUCCESS ) THEN
2470	DO ji = 1, SIZE(ldtxt)
2471	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
2472	END DO
2473	WRITE(*, cform_err)
2474	WRITE(, ) ' lib_mpp: Error in routine mpi_initialized'
2475	CALL mpi_abort( mpi_comm_world, code, ierr )
2476	ENDIF
2477	!
2478	IF( .NOT. mpi_was_called ) THEN
2479	CALL mpi_init( code )
2480	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
2481	IF ( code /= MPI_SUCCESS ) THEN
2482	DO ji = 1, SIZE(ldtxt)
2483	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
2484	END DO
2485	WRITE(*, cform_err)
2486	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
2487	CALL mpi_abort( mpi_comm_world, code, ierr )
2488	ENDIF
2489	ENDIF
2490	!
2491	IF( nn_buffer > 0 ) THEN
2492	WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1
2493	! Buffer allocation and attachment
2494	ALLOCATE( tampon(nn_buffer), stat = ierr )
2495	IF( ierr /= 0 ) THEN
2496	DO ji = 1, SIZE(ldtxt)
2497	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
2498	END DO
2499	WRITE(*, cform_err)
2500	WRITE(, ) ' lib_mpp: Error in ALLOCATE', ierr
2501	CALL mpi_abort( mpi_comm_world, code, ierr )
2502	END IF
2503	CALL mpi_buffer_attach( tampon, nn_buffer, code )
2504	ENDIF
2505	!
2506	END SUBROUTINE mpi_init_opa
2507
2508	#if defined key_mpp_rep
2509	SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
2510	!!---------------------------------------------------------------------
2511	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
2512	!!
2513	!! Modification of original codes written by David H. Bailey
2514	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
2515	!!---------------------------------------------------------------------
2516	INTEGER, INTENT(in) :: ilen, itype
2517	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
2518	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
2519	!
2520	REAL(wp) :: zerr, zt1, zt2 ! local work variables
2521	INTEGER :: ji, ztmp ! local scalar
2522
2523	ztmp = itype ! avoid compilation warning
2524
2525	DO ji=1,ilen
2526	! Compute ydda + yddb using Knuth's trick.
2527	zt1 = real(ydda(ji)) + real(yddb(ji))
2528	zerr = zt1 - real(ydda(ji))
2529	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
2530	+ aimag(ydda(ji)) + aimag(yddb(ji))
2531
2532	! The result is zt1 + zt2, after normalization.
2533	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
2534	END DO
2535
2536	END SUBROUTINE DDPDD_MPI
2537	#endif
2538
2539	#else
2540	!!----------------------------------------------------------------------
2541	!! Default case: Dummy module share memory computing
2542	!!----------------------------------------------------------------------
2543	USE in_out_manager
2544
2545	INTERFACE mpp_sum
2546	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
2547	END INTERFACE
2548	INTERFACE mpp_max
2549	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
2550	END INTERFACE
2551	INTERFACE mpp_min
2552	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
2553	END INTERFACE
2554	INTERFACE mppobc
2555	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
2556	END INTERFACE
2557	INTERFACE mpp_minloc
2558	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
2559	END INTERFACE
2560	INTERFACE mpp_maxloc
2561	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
2562	END INTERFACE
2563
2564	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
2565	INTEGER :: ncomm_ice
2566	!!----------------------------------------------------------------------
2567	CONTAINS
2568
2569	INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function
2570	INTEGER, INTENT(in) :: kumout
2571	lib_mpp_alloc = 0
2572	END FUNCTION lib_mpp_alloc
2573
2574	FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) RESULT (function_value)
2575	INTEGER, OPTIONAL , INTENT(in ) :: localComm
2576	CHARACTER(len=*),DIMENSION(:) :: ldtxt
2577	INTEGER :: kumnam, kstop
2578	IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0
2579	IF( .FALSE. ) ldtxt(:) = 'never done'
2580	END FUNCTION mynode
2581
2582	SUBROUTINE mppsync ! Dummy routine
2583	END SUBROUTINE mppsync
2584
2585	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
2586	REAL , DIMENSION(:) :: parr
2587	INTEGER :: kdim
2588	INTEGER, OPTIONAL :: kcom
2589	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
2590	END SUBROUTINE mpp_sum_as
2591
2592	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
2593	REAL , DIMENSION(:,:) :: parr
2594	INTEGER :: kdim
2595	INTEGER, OPTIONAL :: kcom
2596	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
2597	END SUBROUTINE mpp_sum_a2s
2598
2599	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
2600	INTEGER, DIMENSION(:) :: karr
2601	INTEGER :: kdim
2602	INTEGER, OPTIONAL :: kcom
2603	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
2604	END SUBROUTINE mpp_sum_ai
2605
2606	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
2607	REAL :: psca
2608	INTEGER, OPTIONAL :: kcom
2609	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
2610	END SUBROUTINE mpp_sum_s
2611
2612	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
2613	integer :: kint
2614	INTEGER, OPTIONAL :: kcom
2615	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
2616	END SUBROUTINE mpp_sum_i
2617
2618	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
2619	REAL , DIMENSION(:) :: parr
2620	INTEGER :: kdim
2621	INTEGER, OPTIONAL :: kcom
2622	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2623	END SUBROUTINE mppmax_a_real
2624
2625	SUBROUTINE mppmax_real( psca, kcom )
2626	REAL :: psca
2627	INTEGER, OPTIONAL :: kcom
2628	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
2629	END SUBROUTINE mppmax_real
2630
2631	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
2632	REAL , DIMENSION(:) :: parr
2633	INTEGER :: kdim
2634	INTEGER, OPTIONAL :: kcom
2635	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2636	END SUBROUTINE mppmin_a_real
2637
2638	SUBROUTINE mppmin_real( psca, kcom )
2639	REAL :: psca
2640	INTEGER, OPTIONAL :: kcom
2641	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
2642	END SUBROUTINE mppmin_real
2643
2644	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
2645	INTEGER, DIMENSION(:) :: karr
2646	INTEGER :: kdim
2647	INTEGER, OPTIONAL :: kcom
2648	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2649	END SUBROUTINE mppmax_a_int
2650
2651	SUBROUTINE mppmax_int( kint, kcom)
2652	INTEGER :: kint
2653	INTEGER, OPTIONAL :: kcom
2654	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
2655	END SUBROUTINE mppmax_int
2656
2657	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
2658	INTEGER, DIMENSION(:) :: karr
2659	INTEGER :: kdim
2660	INTEGER, OPTIONAL :: kcom
2661	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2662	END SUBROUTINE mppmin_a_int
2663
2664	SUBROUTINE mppmin_int( kint, kcom )
2665	INTEGER :: kint
2666	INTEGER, OPTIONAL :: kcom
2667	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
2668	END SUBROUTINE mppmin_int
2669
2670	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2671	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
2672	REAL, DIMENSION(:) :: parr ! variable array
2673	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum
2674	END SUBROUTINE mppobc_1d
2675
2676	SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2677	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
2678	REAL, DIMENSION(:,:) :: parr ! variable array
2679	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum
2680	END SUBROUTINE mppobc_2d
2681
2682	SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2683	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
2684	REAL, DIMENSION(:,:,:) :: parr ! variable array
2685	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
2686	END SUBROUTINE mppobc_3d
2687
2688	SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2689	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
2690	REAL, DIMENSION(:,:,:,:) :: parr ! variable array
2691	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
2692	END SUBROUTINE mppobc_4d
2693
2694	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
2695	REAL :: pmin
2696	REAL , DIMENSION (:,:) :: ptab, pmask
2697	INTEGER :: ki, kj
2698	WRITE(,) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
2699	END SUBROUTINE mpp_minloc2d
2700
2701	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
2702	REAL :: pmin
2703	REAL , DIMENSION (:,:,:) :: ptab, pmask
2704	INTEGER :: ki, kj, kk
2705	WRITE(,) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2706	END SUBROUTINE mpp_minloc3d
2707
2708	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2709	REAL :: pmax
2710	REAL , DIMENSION (:,:) :: ptab, pmask
2711	INTEGER :: ki, kj
2712	WRITE(,) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
2713	END SUBROUTINE mpp_maxloc2d
2714
2715	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2716	REAL :: pmax
2717	REAL , DIMENSION (:,:,:) :: ptab, pmask
2718	INTEGER :: ki, kj, kk
2719	WRITE(,) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2720	END SUBROUTINE mpp_maxloc3d
2721
2722	SUBROUTINE mppstop
2723	WRITE(,) 'mppstop: You should not have seen this print! error?'
2724	END SUBROUTINE mppstop
2725
2726	SUBROUTINE mpp_ini_ice( kcom, knum )
2727	INTEGER :: kcom, knum
2728	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
2729	END SUBROUTINE mpp_ini_ice
2730
2731	SUBROUTINE mpp_ini_znl( knum )
2732	INTEGER :: knum
2733	WRITE(,) 'mpp_ini_znl: You should not have seen this print! error?', knum
2734	END SUBROUTINE mpp_ini_znl
2735
2736	SUBROUTINE mpp_comm_free( kcom )
2737	INTEGER :: kcom
2738	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?', kcom
2739	END SUBROUTINE mpp_comm_free
2740	#endif
2741
2742	!!----------------------------------------------------------------------
2743	!! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn routines
2744	!!----------------------------------------------------------------------
2745
2746	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
2747	& cd6, cd7, cd8, cd9, cd10 )
2748	!!----------------------------------------------------------------------
2749	!! * ROUTINE stop_opa *
2750	!!
2751	!! ** Purpose : print in ocean.outpput file a error message and
2752	!! increment the error number (nstop) by one.
2753	!!----------------------------------------------------------------------
2754	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
2755	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
2756	!!----------------------------------------------------------------------
2757	!
2758	nstop = nstop + 1
2759	IF(lwp) THEN
2760	WRITE(numout,cform_err)
2761	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
2762	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
2763	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
2764	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
2765	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
2766	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
2767	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
2768	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
2769	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
2770	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
2771	ENDIF
2772	CALL FLUSH(numout )
2773	IF( numstp /= -1 ) CALL FLUSH(numstp )
2774	IF( numsol /= -1 ) CALL FLUSH(numsol )
2775	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
2776	!
2777	IF( cd1 == 'STOP' ) THEN
2778	IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
2779	CALL mppstop()
2780	ENDIF
2781	!
2782	END SUBROUTINE ctl_stop
2783
2784
2785	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
2786	& cd6, cd7, cd8, cd9, cd10 )
2787	!!----------------------------------------------------------------------
2788	!! * ROUTINE stop_warn *
2789	!!
2790	!! ** Purpose : print in ocean.outpput file a error message and
2791	!! increment the warning number (nwarn) by one.
2792	!!----------------------------------------------------------------------
2793	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
2794	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
2795	!!----------------------------------------------------------------------
2796	!
2797	nwarn = nwarn + 1
2798	IF(lwp) THEN
2799	WRITE(numout,cform_war)
2800	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
2801	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
2802	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
2803	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
2804	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
2805	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
2806	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
2807	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
2808	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
2809	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
2810	ENDIF
2811	CALL FLUSH(numout)
2812	!
2813	END SUBROUTINE ctl_warn
2814
2815
2816	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
2817	!!----------------------------------------------------------------------
2818	!! * ROUTINE ctl_opn *
2819	!!
2820	!! ** Purpose : Open file and check if required file is available.
2821	!!
2822	!! ** Method : Fortan open
2823	!!----------------------------------------------------------------------
2824	INTEGER , INTENT( out) :: knum ! logical unit to open
2825	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
2826	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
2827	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
2828	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
2829	INTEGER , INTENT(in ) :: klengh ! record length
2830	INTEGER , INTENT(in ) :: kout ! number of logical units for write
2831	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
2832	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
2833	!!
2834	CHARACTER(len=80) :: clfile
2835	INTEGER :: iost
2836	!!----------------------------------------------------------------------
2837
2838	! adapt filename
2839	! ----------------
2840	clfile = TRIM(cdfile)
2841	IF( PRESENT( karea ) ) THEN
2842	IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
2843	ENDIF
2844	#if defined key_agrif
2845	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
2846	knum=Agrif_Get_Unit()
2847	#else
2848	knum=get_unit()
2849	#endif
2850
2851	iost=0
2852	IF( cdacce(1:6) == 'DIRECT' ) THEN
2853	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
2854	ELSE
2855	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
2856	ENDIF
2857	IF( iost == 0 ) THEN
2858	IF(ldwp) THEN
2859	WRITE(kout,*) ' file : ', clfile,' open ok'
2860	WRITE(kout,*) ' unit = ', knum
2861	WRITE(kout,*) ' status = ', cdstat
2862	WRITE(kout,*) ' form = ', cdform
2863	WRITE(kout,*) ' access = ', cdacce
2864	WRITE(kout,*)
2865	ENDIF
2866	ENDIF
2867	100 CONTINUE
2868	IF( iost /= 0 ) THEN
2869	IF(ldwp) THEN
2870	WRITE(kout,*)
2871	WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
2872	WRITE(kout,*) ' ======= === '
2873	WRITE(kout,*) ' unit = ', knum
2874	WRITE(kout,*) ' status = ', cdstat
2875	WRITE(kout,*) ' form = ', cdform
2876	WRITE(kout,*) ' access = ', cdacce
2877	WRITE(kout,*) ' iostat = ', iost
2878	WRITE(kout,*) ' we stop. verify the file '
2879	WRITE(kout,*)
2880	ENDIF
2881	STOP 'ctl_opn bad opening'
2882	ENDIF
2883
2884	END SUBROUTINE ctl_opn
2885
2886
2887	INTEGER FUNCTION get_unit()
2888	!!----------------------------------------------------------------------
2889	!! * FUNCTION get_unit *
2890	!!
2891	!! ** Purpose : return the index of an unused logical unit
2892	!!----------------------------------------------------------------------
2893	LOGICAL :: llopn
2894	!!----------------------------------------------------------------------
2895	!
2896	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
2897	llopn = .TRUE.
2898	DO WHILE( (get_unit < 998) .AND. llopn )
2899	get_unit = get_unit + 1
2900	INQUIRE( unit = get_unit, opened = llopn )
2901	END DO
2902	IF( (get_unit == 999) .AND. llopn ) THEN
2903	CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
2904	get_unit = -1
2905	ENDIF
2906	!
2907	END FUNCTION get_unit
2908
2909	!!----------------------------------------------------------------------
2910	END MODULE lib_mpp

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

Download in other formats: