Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

lib_mpp.F90 @ 10207

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

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

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

Context Navigation

source: branches/UKMO/dev_r10171_test_crs_AMM7/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 10207

Download in other formats: