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

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

lib_mpp.F90 in branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2014/dev_r4621_NOC4_BDY_VERT_INTERP/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4792

Last change on this file since 4792 was 4792, checked in by jamesharle, 10 years ago
Updates to code after first successful test + merge with HEAD of trunk
Property svn:keywords set to `Id`
File size: 137.8 KB

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

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

Download in other formats: