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 @ 3849

Last change on this file since 3849 was 3849, checked in by trackstand2, 11 years ago
Merge branch 'partitioner'
Property svn:keywords set to `Id`
File size: 129.0 KB

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

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

Download in other formats: