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

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

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

Context Navigation

source: branches/UKMO/dev_r5107_kara_mld/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5244

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

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

Download in other formats: