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

Context Navigation

source: branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6772

Last change on this file since 6772 was 6772, checked in by cbricaud, 8 years ago
clean in coarsening branch
Property svn:keywords set to `Id`
File size: 165.3 KB

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

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

Download in other formats: