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

Context Navigation

source: branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6060

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

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

Download in other formats: