Context Navigation

lib_mpp.F90 @ 6546

Last change on this file since 6546 was 6546, checked in by frrh, 8 years ago

Commit final changes relating to manual addition of relevant code
from fcm:NEMO.xm/branches/UKMO/dev_r5107_hadgem3_mct@6355.

Note this is a subset of the total changnes... I have ecluded those which
have become or appear redundant or unnecessary.

This version bit compares with the original.

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

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

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

Context Navigation

source: branches/UKMO/dev_r5518_MO_couple_package/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6546

Download in other formats: