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

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 3598

Last change on this file since 3598 was 3598, checked in by rblod, 11 years ago
Change of some variable range for TAM in 3.4 - Ticket #1004
Property svn:keywords set to `Id`
File size: 129.5 KB

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

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

Download in other formats: