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

Context Navigation

source: branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5883

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

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

Download in other formats: