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

Context Navigation

source: branches/UKMO/AMM15_v3_6_STABLE_package_collate_coupling/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 10392

Last change on this file since 10392 was 10392, checked in by jcastill, 5 years ago
Merge branch r6232_hadgem3_mct@7457
File size: 164.8 KB

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

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

Download in other formats: