Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

lib_mpp.F90 @ 9383

Last change on this file since 9383 was 9383, checked in by andmirek, 6 years ago
#2050 fixes and changes
File size: 173.8 KB

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

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

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

Context Navigation

source: branches/UKMO/test_moci_test_suite_namelist_read/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 9383

Download in other formats: