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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

lib_mpp.F90 in branches/UKMO/dev_r5518_clean_shutdown/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/UKMO/dev_r5518_clean_shutdown/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6897

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

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

Download in other formats: