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

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

lib_mpp.F90 in trunk/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5412

Last change on this file since 5412 was 5412, checked in by hadcv, 9 years ago
Set mpi_comm_opa in non-MPP cases (addresses #1533) Add an xios_context_finalize in step_C1D
Property svn:keywords set to `Id`
File size: 149.3 KB

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

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

Download in other formats: