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/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 2690

Last change on this file since 2690 was 2690, checked in by gm, 13 years ago
dynamic mem: #785 ; homogeneization of the coding style associated with dyn allocation
Property svn:keywords set to `Id`
File size: 122.1 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	!!----------------------------------------------------------------------
22
23	!!----------------------------------------------------------------------
24	!! ctl_stop : update momentum and tracer Kz from a tke scheme
25	!! ctl_warn : initialization, namelist read, and parameters control
26	!! ctl_opn : Open file and check if required file is available.
27	!! get_unit : give the index of an unused logical unit
28	!!----------------------------------------------------------------------
29	#if defined key_mpp_mpi
30	!!----------------------------------------------------------------------
31	!! 'key_mpp_mpi' MPI massively parallel processing library
32	!!----------------------------------------------------------------------
33	!! lib_mpp_alloc : allocate mpp arrays
34	!! mynode : indentify the processor unit
35	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
36	!! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays
37	!! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
38	!! mpprecv :
39	!! mppsend : SUBROUTINE mpp_ini_znl
40	!! mppscatter :
41	!! mppgather :
42	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
43	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
44	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
45	!! mpp_minloc :
46	!! mpp_maxloc :
47	!! mppsync :
48	!! mppstop :
49	!! mppobc : variant of mpp_lnk for open boundary condition
50	!! mpp_ini_north : initialisation of north fold
51	!! mpp_lbc_north : north fold processors gathering
52	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
53	!!----------------------------------------------------------------------
54	USE dom_oce ! ocean space and time domain
55	USE lbcnfd ! north fold treatment
56	USE in_out_manager ! I/O manager
57
58	IMPLICIT NONE
59	PRIVATE
60
61	PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn
62	PUBLIC mynode, mppstop, mppsync, mpp_comm_free
63	PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
64	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
65	PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
66	PUBLIC mppobc, mpp_ini_ice, mpp_ini_znl
67	PUBLIC mppsize
68	PUBLIC lib_mpp_alloc ! Called in nemogcm.F90
69
70	!! * Interfaces
71	!! define generic interface for these routine as they are called sometimes
72	!! with scalar arguments instead of array arguments, which causes problems
73	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
74	INTERFACE mpp_min
75	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
76	END INTERFACE
77	INTERFACE mpp_max
78	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
79	END INTERFACE
80	INTERFACE mpp_sum
81	# if defined key_mpp_rep
82	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
83	mppsum_realdd, mppsum_a_realdd
84	# else
85	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
86	# endif
87	END INTERFACE
88	INTERFACE mpp_lbc_north
89	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
90	END INTERFACE
91	INTERFACE mpp_minloc
92	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
93	END INTERFACE
94	INTERFACE mpp_maxloc
95	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
96	END INTERFACE
97
98	!! ========================= !!
99	!! MPI variable definition !!
100	!! ========================= !!
101	!$AGRIF_DO_NOT_TREAT
102	INCLUDE 'mpif.h'
103	!$AGRIF_END_DO_NOT_TREAT
104
105	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
106
107	INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)
108
109	INTEGER :: mppsize ! number of process
110	INTEGER :: mpprank ! process number [ 0 - size-1 ]
111	!$AGRIF_DO_NOT_TREAT
112	INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator
113	!$AGRIF_END_DO_NOT_TREAT
114
115	# if defined key_mpp_rep
116	INTEGER :: MPI_SUMDD
117	# endif
118
119	! variables used in case of sea-ice
120	INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice
121	INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)
122	INTEGER :: ndim_rank_ice ! number of 'ice' processors
123	INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm
124	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice
125
126	! variables used for zonal integration
127	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
128	LOGICAL, PUBLIC :: l_znl_root ! True on the 'left'most processor on the same row
129	INTEGER :: ngrp_znl ! group ID for the znl processors
130	INTEGER :: ndim_rank_znl ! number of processors on the same zonal average
131	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain
132
133	! North fold condition in mpp_mpi with jpni > 1
134	INTEGER :: ngrp_world ! group ID for the world processors
135	INTEGER :: ngrp_opa ! group ID for the opa processors
136	INTEGER :: ngrp_north ! group ID for the northern processors (to be fold)
137	INTEGER :: ncomm_north ! communicator made by the processors belonging to ngrp_north
138	INTEGER :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)
139	INTEGER :: njmppmax ! value of njmpp for the processors of the northern line
140	INTEGER :: north_root ! number (in the comm_opa) of proc 0 in the northern comm
141	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north ! dimension ndim_rank_north
142
143	! Type of send : standard, buffered, immediate
144	CHARACTER(len=1) :: cn_mpi_send = 'S' ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
145	LOGICAL :: l_isend = .FALSE. ! isend use indicator (T if cn_mpi_send='I')
146	INTEGER :: nn_buffer = 0 ! size of the buffer in case of mpi_bsend
147
148	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend
149
150	! message passing arrays
151	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4ns, t4sn ! 2 x 3d for north-south & south-north
152	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4ew, t4we ! 2 x 3d for east-west & west-east
153	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4p1, t4p2 ! 2 x 3d for north fold
154	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3ns, t3sn ! 3d for north-south & south-north
155	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3ew, t3we ! 3d for east-west & west-east
156	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3p1, t3p2 ! 3d for north fold
157	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2ns, t2sn ! 2d for north-south & south-north
158	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2ew, t2we ! 2d for east-west & west-east
159	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2p1, t2p2 ! 2d for north fold
160	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: tr2ns, tr2sn ! 2d for north-south & south-north + extra outer halo
161	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: tr2ew, tr2we ! 2d for east-west & west-east + extra outer halo
162
163	! Arrays used in mpp_lbc_north_3d()
164	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: ztab, znorthloc
165	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: znorthgloio
166
167	! Arrays used in mpp_lbc_north_2d()
168	REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_2d, znorthloc_2d
169	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_2d
170
171	! Arrays used in mpp_lbc_north_e()
172	REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: ztab_e, znorthloc_e
173	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: znorthgloio_e
174
175	!!----------------------------------------------------------------------
176	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
177	!! $Id$
178	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
179	!!----------------------------------------------------------------------
180	CONTAINS
181
182	INTEGER FUNCTION lib_mpp_alloc( kumout )
183	!!----------------------------------------------------------------------
184	!! * routine lib_mpp_alloc *
185	!!----------------------------------------------------------------------
186	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
187	!!----------------------------------------------------------------------
188	!
189	ALLOCATE( t4ns(jpi,jprecj,jpk,2,2) , t4sn(jpi,jprecj,jpk,2,2) , &
190	& t4ew(jpj,jpreci,jpk,2,2) , t4we(jpj,jpreci,jpk,2,2) , &
191	& t4p1(jpi,jprecj,jpk,2,2) , t4p2(jpi,jprecj,jpk,2,2) , &
192	& t3ns(jpi,jprecj,jpk,2) , t3sn(jpi,jprecj,jpk,2) , &
193	& t3ew(jpj,jpreci,jpk,2) , t3we(jpj,jpreci,jpk,2) , &
194	& t3p1(jpi,jprecj,jpk,2) , t3p2(jpi,jprecj,jpk,2) , &
195	& t2ns(jpi,jprecj ,2) , t2sn(jpi,jprecj ,2) , &
196	& t2ew(jpj,jpreci ,2) , t2we(jpj,jpreci ,2) , &
197	& t2p1(jpi,jprecj ,2) , t2p2(jpi,jprecj ,2) , &
198	!
199	& tr2ns(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) , &
200	& tr2sn(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) , &
201	& tr2ew(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) , &
202	& tr2we(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) , &
203	!
204	& ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) , &
205	!
206	& ztab_2d(jpiglo,4) , znorthloc_2d(jpi,4) , znorthgloio_2d(jpi,4,jpni) , &
207	!
208	& ztab_e(jpiglo,4+2jpr2dj) , znorthloc_e(jpi,4+2jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) , &
209	!
210	& STAT=lib_mpp_alloc )
211	!
212	IF( lib_mpp_alloc /= 0 ) THEN
213	WRITE(kumout,cform_war)
214	WRITE(kumout,*) 'lib_mpp_alloc : failed to allocate arrays'
215	ENDIF
216	!
217	END FUNCTION lib_mpp_alloc
218
219
220	FUNCTION mynode( ldtxt, kumnam, kstop, localComm )
221	!!----------------------------------------------------------------------
222	!! * routine mynode *
223	!!
224	!! ** Purpose : Find processor unit
225	!!----------------------------------------------------------------------
226	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
227	INTEGER , INTENT(in ) :: kumnam ! namelist logical unit
228	INTEGER , INTENT(inout) :: kstop ! stop indicator
229	INTEGER, OPTIONAL , INTENT(in ) :: localComm
230	!
231	INTEGER :: mynode, ierr, code, ji, ii
232	LOGICAL :: mpi_was_called
233	!
234	NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij
235	!!----------------------------------------------------------------------
236	!
237	ii = 1
238	WRITE(ldtxt(ii),*) ; ii = ii + 1
239	WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1
240	WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1
241	!
242	jpni = -1; jpnj = -1; jpnij = -1
243	REWIND( kumnam ) ! Namelist namrun : parameters of the run
244	READ ( kumnam, nammpp )
245	! ! control print
246	WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1
247	WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
248	WRITE(ldtxt(ii),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer ; ii = ii + 1
249
250	IF(jpnij < 1)THEN
251	! If jpnij is not specified in namelist then we calculate it - this
252	! means there will be no land cutting out.
253	jpnij = jpni * jpnj
254	END IF
255
256	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
257	WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically'; ii = ii + 1
258	ELSE
259	WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni; ii = ii + 1
260	WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj; ii = ii + 1
261	WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij; ii = ii +1
262	END IF
263
264	CALL mpi_initialized ( mpi_was_called, code )
265	IF( code /= MPI_SUCCESS ) THEN
266	DO ji = 1, SIZE(ldtxt)
267	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
268	END DO
269	WRITE(*, cform_err)
270	WRITE(, ) 'lib_mpp: Error in routine mpi_initialized'
271	CALL mpi_abort( mpi_comm_world, code, ierr )
272	ENDIF
273
274	IF( mpi_was_called ) THEN
275	!
276	SELECT CASE ( cn_mpi_send )
277	CASE ( 'S' ) ! Standard mpi send (blocking)
278	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
279	CASE ( 'B' ) ! Buffer mpi send (blocking)
280	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
281	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
282	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
283	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
284	l_isend = .TRUE.
285	CASE DEFAULT
286	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
287	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
288	kstop = kstop + 1
289	END SELECT
290	ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
291	WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1
292	WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1
293	kstop = kstop + 1
294	ELSE
295	SELECT CASE ( cn_mpi_send )
296	CASE ( 'S' ) ! Standard mpi send (blocking)
297	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
298	CALL mpi_init( ierr )
299	CASE ( 'B' ) ! Buffer mpi send (blocking)
300	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
301	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
302	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
303	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
304	l_isend = .TRUE.
305	CALL mpi_init( ierr )
306	CASE DEFAULT
307	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
308	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
309	kstop = kstop + 1
310	END SELECT
311	!
312	ENDIF
313
314	IF( PRESENT(localComm) ) THEN
315	IF( Agrif_Root() ) THEN
316	mpi_comm_opa = localComm
317	ENDIF
318	ELSE
319	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
320	IF( code /= MPI_SUCCESS ) THEN
321	DO ji = 1, SIZE(ldtxt)
322	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
323	END DO
324	WRITE(*, cform_err)
325	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
326	CALL mpi_abort( mpi_comm_world, code, ierr )
327	ENDIF
328	ENDIF
329
330	CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
331	CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
332	mynode = mpprank
333	!
334	#if defined key_mpp_rep
335	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
336	#endif
337	!
338	END FUNCTION mynode
339
340
341	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
342	!!----------------------------------------------------------------------
343	!! * routine mpp_lnk_3d *
344	!!
345	!! ** Purpose : Message passing manadgement
346	!!
347	!! ** Method : Use mppsend and mpprecv function for passing mask
348	!! between processors following neighboring subdomains.
349	!! domain parameters
350	!! nlci : first dimension of the local subdomain
351	!! nlcj : second dimension of the local subdomain
352	!! nbondi : mark for "east-west local boundary"
353	!! nbondj : mark for "north-south local boundary"
354	!! noea : number for local neighboring processors
355	!! nowe : number for local neighboring processors
356	!! noso : number for local neighboring processors
357	!! nono : number for local neighboring processors
358	!!
359	!! ** Action : ptab with update value at its periphery
360	!!
361	!!----------------------------------------------------------------------
362	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
363	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
364	! ! = T , U , V , F , W points
365	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
366	! ! = 1. , the sign is kept
367	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
368	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
369	!!
370	INTEGER :: ji, jj, jk, jl ! dummy loop indices
371	INTEGER :: imigr, iihom, ijhom ! temporary integers
372	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
373	REAL(wp) :: zland
374	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
375	!!----------------------------------------------------------------------
376
377	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
378	ELSE ; zland = 0.e0 ! zero by default
379	ENDIF
380
381	! 1. standard boundary treatment
382	! ------------------------------
383	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
384	!
385	! WARNING ptab is defined only between nld and nle
386	DO jk = 1, jpk
387	DO jj = nlcj+1, jpj ! added line(s) (inner only)
388	ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk)
389	ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk)
390	ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk)
391	END DO
392	DO ji = nlci+1, jpi ! added column(s) (full)
393	ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk)
394	ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk)
395	ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk)
396	END DO
397	END DO
398	!
399	ELSE ! standard close or cyclic treatment
400	!
401	! ! East-West boundaries
402	! !* Cyclic east-west
403	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
404	ptab( 1 ,:,:) = ptab(jpim1,:,:)
405	ptab(jpi,:,:) = ptab( 2 ,:,:)
406	ELSE !* closed
407	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
408	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
409	ENDIF
410	! ! North-South boundaries (always closed)
411	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point
412	ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north
413	!
414	ENDIF
415
416	! 2. East and west directions exchange
417	! ------------------------------------
418	! we play with the neigbours AND the row number because of the periodicity
419	!
420	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
421	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
422	iihom = nlci-nreci
423	DO jl = 1, jpreci
424	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
425	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
426	END DO
427	END SELECT
428	!
429	! ! Migrations
430	imigr = jpreci * jpj * jpk
431	!
432	SELECT CASE ( nbondi )
433	CASE ( -1 )
434	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
435	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
436	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
437	CASE ( 0 )
438	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
439	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
440	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
441	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
442	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
443	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
444	CASE ( 1 )
445	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
446	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
447	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
448	END SELECT
449	!
450	! ! Write Dirichlet lateral conditions
451	iihom = nlci-jpreci
452	!
453	SELECT CASE ( nbondi )
454	CASE ( -1 )
455	DO jl = 1, jpreci
456	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
457	END DO
458	CASE ( 0 )
459	DO jl = 1, jpreci
460	ptab(jl ,:,:) = t3we(:,jl,:,2)
461	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
462	END DO
463	CASE ( 1 )
464	DO jl = 1, jpreci
465	ptab(jl ,:,:) = t3we(:,jl,:,2)
466	END DO
467	END SELECT
468
469
470	! 3. North and south directions
471	! -----------------------------
472	! always closed : we play only with the neigbours
473	!
474	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
475	ijhom = nlcj-nrecj
476	DO jl = 1, jprecj
477	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
478	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
479	END DO
480	ENDIF
481	!
482	! ! Migrations
483	imigr = jprecj * jpi * jpk
484	!
485	SELECT CASE ( nbondj )
486	CASE ( -1 )
487	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
488	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
489	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
490	CASE ( 0 )
491	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
492	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
493	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
494	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
495	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
496	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
497	CASE ( 1 )
498	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
499	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
500	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
501	END SELECT
502	!
503	! ! Write Dirichlet lateral conditions
504	ijhom = nlcj-jprecj
505	!
506	SELECT CASE ( nbondj )
507	CASE ( -1 )
508	DO jl = 1, jprecj
509	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
510	END DO
511	CASE ( 0 )
512	DO jl = 1, jprecj
513	ptab(:,jl ,:) = t3sn(:,jl,:,2)
514	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
515	END DO
516	CASE ( 1 )
517	DO jl = 1, jprecj
518	ptab(:,jl,:) = t3sn(:,jl,:,2)
519	END DO
520	END SELECT
521
522
523	! 4. north fold treatment
524	! -----------------------
525	!
526	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
527	!
528	SELECT CASE ( jpni )
529	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
530	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
531	END SELECT
532	!
533	ENDIF
534	!
535	END SUBROUTINE mpp_lnk_3d
536
537
538	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
539	!!----------------------------------------------------------------------
540	!! * routine mpp_lnk_2d *
541	!!
542	!! ** Purpose : Message passing manadgement for 2d array
543	!!
544	!! ** Method : Use mppsend and mpprecv function for passing mask
545	!! between processors following neighboring subdomains.
546	!! domain parameters
547	!! nlci : first dimension of the local subdomain
548	!! nlcj : second dimension of the local subdomain
549	!! nbondi : mark for "east-west local boundary"
550	!! nbondj : mark for "north-south local boundary"
551	!! noea : number for local neighboring processors
552	!! nowe : number for local neighboring processors
553	!! noso : number for local neighboring processors
554	!! nono : number for local neighboring processors
555	!!
556	!!----------------------------------------------------------------------
557	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
558	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
559	! ! = T , U , V , F , W and I points
560	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
561	! ! = 1. , the sign is kept
562	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
563	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
564	!!
565	INTEGER :: ji, jj, jl ! dummy loop indices
566	INTEGER :: imigr, iihom, ijhom ! temporary integers
567	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
568	REAL(wp) :: zland
569	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
570	!!----------------------------------------------------------------------
571
572	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
573	ELSE ; zland = 0.e0 ! zero by default
574	ENDIF
575
576	! 1. standard boundary treatment
577	! ------------------------------
578	!
579	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
580	!
581	! WARNING pt2d is defined only between nld and nle
582	DO jj = nlcj+1, jpj ! added line(s) (inner only)
583	pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej)
584	pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej)
585	pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej)
586	END DO
587	DO ji = nlci+1, jpi ! added column(s) (full)
588	pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej)
589	pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj )
590	pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej)
591	END DO
592	!
593	ELSE ! standard close or cyclic treatment
594	!
595	! ! East-West boundaries
596	IF( nbondi == 2 .AND. & ! Cyclic east-west
597	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
598	pt2d( 1 ,:) = pt2d(jpim1,:) ! west
599	pt2d(jpi,:) = pt2d( 2 ,:) ! east
600	ELSE ! closed
601	IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point
602	pt2d(nlci-jpreci+1:jpi ,:) = zland ! north
603	ENDIF
604	! ! North-South boundaries (always closed)
605	IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point
606	pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north
607	!
608	ENDIF
609
610	! 2. East and west directions exchange
611	! ------------------------------------
612	! we play with the neigbours AND the row number because of the periodicity
613	!
614	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
615	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
616	iihom = nlci-nreci
617	DO jl = 1, jpreci
618	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
619	t2we(:,jl,1) = pt2d(iihom +jl,:)
620	END DO
621	END SELECT
622	!
623	! ! Migrations
624	imigr = jpreci * jpj
625	!
626	SELECT CASE ( nbondi )
627	CASE ( -1 )
628	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
629	CALL mpprecv( 1, t2ew(1,1,2), imigr )
630	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
631	CASE ( 0 )
632	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
633	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
634	CALL mpprecv( 1, t2ew(1,1,2), imigr )
635	CALL mpprecv( 2, t2we(1,1,2), imigr )
636	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
637	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
638	CASE ( 1 )
639	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
640	CALL mpprecv( 2, t2we(1,1,2), imigr )
641	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
642	END SELECT
643	!
644	! ! Write Dirichlet lateral conditions
645	iihom = nlci - jpreci
646	!
647	SELECT CASE ( nbondi )
648	CASE ( -1 )
649	DO jl = 1, jpreci
650	pt2d(iihom+jl,:) = t2ew(:,jl,2)
651	END DO
652	CASE ( 0 )
653	DO jl = 1, jpreci
654	pt2d(jl ,:) = t2we(:,jl,2)
655	pt2d(iihom+jl,:) = t2ew(:,jl,2)
656	END DO
657	CASE ( 1 )
658	DO jl = 1, jpreci
659	pt2d(jl ,:) = t2we(:,jl,2)
660	END DO
661	END SELECT
662
663
664	! 3. North and south directions
665	! -----------------------------
666	! always closed : we play only with the neigbours
667	!
668	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
669	ijhom = nlcj-nrecj
670	DO jl = 1, jprecj
671	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
672	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
673	END DO
674	ENDIF
675	!
676	! ! Migrations
677	imigr = jprecj * jpi
678	!
679	SELECT CASE ( nbondj )
680	CASE ( -1 )
681	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
682	CALL mpprecv( 3, t2ns(1,1,2), imigr )
683	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
684	CASE ( 0 )
685	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
686	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
687	CALL mpprecv( 3, t2ns(1,1,2), imigr )
688	CALL mpprecv( 4, t2sn(1,1,2), imigr )
689	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
690	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
691	CASE ( 1 )
692	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
693	CALL mpprecv( 4, t2sn(1,1,2), imigr )
694	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
695	END SELECT
696	!
697	! ! Write Dirichlet lateral conditions
698	ijhom = nlcj - jprecj
699	!
700	SELECT CASE ( nbondj )
701	CASE ( -1 )
702	DO jl = 1, jprecj
703	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
704	END DO
705	CASE ( 0 )
706	DO jl = 1, jprecj
707	pt2d(:,jl ) = t2sn(:,jl,2)
708	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
709	END DO
710	CASE ( 1 )
711	DO jl = 1, jprecj
712	pt2d(:,jl ) = t2sn(:,jl,2)
713	END DO
714	END SELECT
715
716
717	! 4. north fold treatment
718	! -----------------------
719	!
720	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
721	!
722	SELECT CASE ( jpni )
723	CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp
724	CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.
725	END SELECT
726	!
727	ENDIF
728	!
729	END SUBROUTINE mpp_lnk_2d
730
731
732	SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
733	!!----------------------------------------------------------------------
734	!! * routine mpp_lnk_3d_gather *
735	!!
736	!! ** Purpose : Message passing manadgement for two 3D arrays
737	!!
738	!! ** Method : Use mppsend and mpprecv function for passing mask
739	!! between processors following neighboring subdomains.
740	!! domain parameters
741	!! nlci : first dimension of the local subdomain
742	!! nlcj : second dimension of the local subdomain
743	!! nbondi : mark for "east-west local boundary"
744	!! nbondj : mark for "north-south local boundary"
745	!! noea : number for local neighboring processors
746	!! nowe : number for local neighboring processors
747	!! noso : number for local neighboring processors
748	!! nono : number for local neighboring processors
749	!!
750	!! ** Action : ptab1 and ptab2 with update value at its periphery
751	!!
752	!!----------------------------------------------------------------------
753	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which
754	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied
755	CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays
756	CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points
757	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
758	!! ! = 1. , the sign is kept
759	INTEGER :: jl ! dummy loop indices
760	INTEGER :: imigr, iihom, ijhom ! temporary integers
761	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
762	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
763	!!----------------------------------------------------------------------
764
765	! 1. standard boundary treatment
766	! ------------------------------
767	! ! East-West boundaries
768	! !* Cyclic east-west
769	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
770	ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
771	ptab1(jpi,:,:) = ptab1( 2 ,:,:)
772	ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
773	ptab2(jpi,:,:) = ptab2( 2 ,:,:)
774	ELSE !* closed
775	IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point
776	IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0
777	ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north
778	ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
779	ENDIF
780
781
782	! ! North-South boundaries
783	IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0 ! south except at F-point
784	IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e0
785	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 ! north
786	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
787
788
789	! 2. East and west directions exchange
790	! ------------------------------------
791	! we play with the neigbours AND the row number because of the periodicity
792	!
793	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
794	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
795	iihom = nlci-nreci
796	DO jl = 1, jpreci
797	t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
798	t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
799	t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
800	t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
801	END DO
802	END SELECT
803	!
804	! ! Migrations
805	imigr = jpreci * jpj * jpk *2
806	!
807	SELECT CASE ( nbondi )
808	CASE ( -1 )
809	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
810	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
811	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
812	CASE ( 0 )
813	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
814	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
815	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
816	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
817	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
818	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
819	CASE ( 1 )
820	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
821	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
822	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
823	END SELECT
824	!
825	! ! Write Dirichlet lateral conditions
826	iihom = nlci - jpreci
827	!
828	SELECT CASE ( nbondi )
829	CASE ( -1 )
830	DO jl = 1, jpreci
831	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
832	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
833	END DO
834	CASE ( 0 )
835	DO jl = 1, jpreci
836	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
837	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
838	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
839	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
840	END DO
841	CASE ( 1 )
842	DO jl = 1, jpreci
843	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
844	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
845	END DO
846	END SELECT
847
848
849	! 3. North and south directions
850	! -----------------------------
851	! always closed : we play only with the neigbours
852	!
853	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
854	ijhom = nlcj - nrecj
855	DO jl = 1, jprecj
856	t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
857	t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
858	t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
859	t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
860	END DO
861	ENDIF
862	!
863	! ! Migrations
864	imigr = jprecj * jpi * jpk * 2
865	!
866	SELECT CASE ( nbondj )
867	CASE ( -1 )
868	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
869	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
870	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
871	CASE ( 0 )
872	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
873	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
874	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
875	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
876	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
877	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
878	CASE ( 1 )
879	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
880	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
881	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
882	END SELECT
883	!
884	! ! Write Dirichlet lateral conditions
885	ijhom = nlcj - jprecj
886	!
887	SELECT CASE ( nbondj )
888	CASE ( -1 )
889	DO jl = 1, jprecj
890	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
891	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
892	END DO
893	CASE ( 0 )
894	DO jl = 1, jprecj
895	ptab1(:,jl ,:) = t4sn(:,jl,:,1,2)
896	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
897	ptab2(:,jl ,:) = t4sn(:,jl,:,2,2)
898	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
899	END DO
900	CASE ( 1 )
901	DO jl = 1, jprecj
902	ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
903	ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
904	END DO
905	END SELECT
906
907
908	! 4. north fold treatment
909	! -----------------------
910	IF( npolj /= 0 ) THEN
911	!
912	SELECT CASE ( jpni )
913	CASE ( 1 )
914	CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs.
915	CALL lbc_nfd ( ptab2, cd_type2, psgn )
916	CASE DEFAULT
917	CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs.
918	CALL mpp_lbc_north (ptab2, cd_type2, psgn)
919	END SELECT
920	!
921	ENDIF
922	!
923	END SUBROUTINE mpp_lnk_3d_gather
924
925
926	SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
927	!!----------------------------------------------------------------------
928	!! * routine mpp_lnk_2d_e *
929	!!
930	!! ** Purpose : Message passing manadgement for 2d array (with halo)
931	!!
932	!! ** Method : Use mppsend and mpprecv function for passing mask
933	!! between processors following neighboring subdomains.
934	!! domain parameters
935	!! nlci : first dimension of the local subdomain
936	!! nlcj : second dimension of the local subdomain
937	!! jpr2di : number of rows for extra outer halo
938	!! jpr2dj : number of columns for extra outer halo
939	!! nbondi : mark for "east-west local boundary"
940	!! nbondj : mark for "north-south local boundary"
941	!! noea : number for local neighboring processors
942	!! nowe : number for local neighboring processors
943	!! noso : number for local neighboring processors
944	!! nono : number for local neighboring processors
945	!!
946	!!----------------------------------------------------------------------
947	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
948	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
949	! ! = T , U , V , F , W and I points
950	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the
951	!! ! north boundary, = 1. otherwise
952	INTEGER :: jl ! dummy loop indices
953	INTEGER :: imigr, iihom, ijhom ! temporary integers
954	INTEGER :: ipreci, iprecj ! temporary integers
955	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
956	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
957	!!----------------------------------------------------------------------
958
959	ipreci = jpreci + jpr2di ! take into account outer extra 2D overlap area
960	iprecj = jprecj + jpr2dj
961
962
963	! 1. standard boundary treatment
964	! ------------------------------
965	! Order matters Here !!!!
966	!
967	! !* North-South boundaries (always colsed)
968	IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jpr2dj : jprecj ) = 0.e0 ! south except at F-point
969	pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0 ! north
970
971	! ! East-West boundaries
972	! !* Cyclic east-west
973	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
974	pt2d(1-jpr2di: 1 ,:) = pt2d(jpim1-jpr2di: jpim1 ,:) ! east
975	pt2d( jpi :jpi+jpr2di,:) = pt2d( 2 :2+jpr2di,:) ! west
976	!
977	ELSE !* closed
978	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpr2di :jpreci ,:) = 0.e0 ! south except at F-point
979	pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0 ! north
980	ENDIF
981	!
982
983	! north fold treatment
984	! -----------------------
985	IF( npolj /= 0 ) THEN
986	!
987	SELECT CASE ( jpni )
988	CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj )
989	CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )
990	END SELECT
991	!
992	ENDIF
993
994	! 2. East and west directions exchange
995	! ------------------------------------
996	! we play with the neigbours AND the row number because of the periodicity
997	!
998	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
999	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
1000	iihom = nlci-nreci-jpr2di
1001	DO jl = 1, ipreci
1002	tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
1003	tr2we(:,jl,1) = pt2d(iihom +jl,:)
1004	END DO
1005	END SELECT
1006	!
1007	! ! Migrations
1008	imigr = ipreci * ( jpj + 2*jpr2dj)
1009	!
1010	SELECT CASE ( nbondi )
1011	CASE ( -1 )
1012	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
1013	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
1014	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1015	CASE ( 0 )
1016	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1017	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
1018	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
1019	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
1020	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1021	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1022	CASE ( 1 )
1023	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1024	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
1025	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1026	END SELECT
1027	!
1028	! ! Write Dirichlet lateral conditions
1029	iihom = nlci - jpreci
1030	!
1031	SELECT CASE ( nbondi )
1032	CASE ( -1 )
1033	DO jl = 1, ipreci
1034	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
1035	END DO
1036	CASE ( 0 )
1037	DO jl = 1, ipreci
1038	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1039	pt2d( iihom+jl,:) = tr2ew(:,jl,2)
1040	END DO
1041	CASE ( 1 )
1042	DO jl = 1, ipreci
1043	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1044	END DO
1045	END SELECT
1046
1047
1048	! 3. North and south directions
1049	! -----------------------------
1050	! always closed : we play only with the neigbours
1051	!
1052	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
1053	ijhom = nlcj-nrecj-jpr2dj
1054	DO jl = 1, iprecj
1055	tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
1056	tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
1057	END DO
1058	ENDIF
1059	!
1060	! ! Migrations
1061	imigr = iprecj * ( jpi + 2*jpr2di )
1062	!
1063	SELECT CASE ( nbondj )
1064	CASE ( -1 )
1065	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
1066	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
1067	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1068	CASE ( 0 )
1069	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1070	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
1071	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
1072	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
1073	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1074	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1075	CASE ( 1 )
1076	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1077	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
1078	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1079	END SELECT
1080	!
1081	! ! Write Dirichlet lateral conditions
1082	ijhom = nlcj - jprecj
1083	!
1084	SELECT CASE ( nbondj )
1085	CASE ( -1 )
1086	DO jl = 1, iprecj
1087	pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
1088	END DO
1089	CASE ( 0 )
1090	DO jl = 1, iprecj
1091	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1092	pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
1093	END DO
1094	CASE ( 1 )
1095	DO jl = 1, iprecj
1096	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1097	END DO
1098	END SELECT
1099
1100	END SUBROUTINE mpp_lnk_2d_e
1101
1102
1103	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1104	!!----------------------------------------------------------------------
1105	!! * routine mppsend *
1106	!!
1107	!! ** Purpose : Send messag passing array
1108	!!
1109	!!----------------------------------------------------------------------
1110	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1111	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
1112	INTEGER , INTENT(in ) :: kdest ! receive process number
1113	INTEGER , INTENT(in ) :: ktyp ! tag of the message
1114	INTEGER , INTENT(in ) :: md_req ! argument for isend
1115	!!
1116	INTEGER :: iflag
1117	!!----------------------------------------------------------------------
1118	!
1119	SELECT CASE ( cn_mpi_send )
1120	CASE ( 'S' ) ! Standard mpi send (blocking)
1121	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
1122	CASE ( 'B' ) ! Buffer mpi send (blocking)
1123	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
1124	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
1125	! be carefull, one more argument here : the mpi request identifier..
1126	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1127	END SELECT
1128	!
1129	END SUBROUTINE mppsend
1130
1131
1132	SUBROUTINE mpprecv( ktyp, pmess, kbytes )
1133	!!----------------------------------------------------------------------
1134	!! * routine mpprecv *
1135	!!
1136	!! ** Purpose : Receive messag passing array
1137	!!
1138	!!----------------------------------------------------------------------
1139	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1140	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
1141	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
1142	!!
1143	INTEGER :: istatus(mpi_status_size)
1144	INTEGER :: iflag
1145	!!----------------------------------------------------------------------
1146	!
1147	CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag )
1148	!
1149	END SUBROUTINE mpprecv
1150
1151
1152	SUBROUTINE mppgather( ptab, kp, pio )
1153	!!----------------------------------------------------------------------
1154	!! * routine mppgather *
1155	!!
1156	!! ** Purpose : Transfert between a local subdomain array and a work
1157	!! array which is distributed following the vertical level.
1158	!!
1159	!!----------------------------------------------------------------------
1160	REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ptab ! subdomain input array
1161	INTEGER , INTENT(in ) :: kp ! record length
1162	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
1163	!!
1164	INTEGER :: itaille, ierror ! temporary integer
1165	!!---------------------------------------------------------------------
1166	!
1167	itaille = jpi * jpj
1168	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
1169	& mpi_double_precision, kp , mpi_comm_opa, ierror )
1170	!
1171	END SUBROUTINE mppgather
1172
1173
1174	SUBROUTINE mppscatter( pio, kp, ptab )
1175	!!----------------------------------------------------------------------
1176	!! * routine mppscatter *
1177	!!
1178	!! ** Purpose : Transfert between awork array which is distributed
1179	!! following the vertical level and the local subdomain array.
1180	!!
1181	!!----------------------------------------------------------------------
1182	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
1183	INTEGER :: kp ! Tag (not used with MPI
1184	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
1185	!!
1186	INTEGER :: itaille, ierror ! temporary integer
1187	!!---------------------------------------------------------------------
1188	!
1189	itaille=jpi*jpj
1190	!
1191	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
1192	& mpi_double_precision, kp , mpi_comm_opa, ierror )
1193	!
1194	END SUBROUTINE mppscatter
1195
1196
1197	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1198	!!----------------------------------------------------------------------
1199	!! * routine mppmax_a_int *
1200	!!
1201	!! ** Purpose : Find maximum value in an integer layout array
1202	!!
1203	!!----------------------------------------------------------------------
1204	INTEGER , INTENT(in ) :: kdim ! size of array
1205	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1206	INTEGER , INTENT(in ), OPTIONAL :: kcom !
1207	!!
1208	INTEGER :: ierror, localcomm ! temporary integer
1209	INTEGER, DIMENSION(kdim) :: iwork
1210	!!----------------------------------------------------------------------
1211	!
1212	localcomm = mpi_comm_opa
1213	IF( PRESENT(kcom) ) localcomm = kcom
1214	!
1215	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1216	!
1217	ktab(:) = iwork(:)
1218	!
1219	END SUBROUTINE mppmax_a_int
1220
1221
1222	SUBROUTINE mppmax_int( ktab, kcom )
1223	!!----------------------------------------------------------------------
1224	!! * routine mppmax_int *
1225	!!
1226	!! ** Purpose : Find maximum value in an integer layout array
1227	!!
1228	!!----------------------------------------------------------------------
1229	INTEGER, INTENT(inout) :: ktab ! ???
1230	INTEGER, INTENT(in ), OPTIONAL :: kcom ! ???
1231	!!
1232	INTEGER :: ierror, iwork, localcomm ! temporary integer
1233	!!----------------------------------------------------------------------
1234	!
1235	localcomm = mpi_comm_opa
1236	IF( PRESENT(kcom) ) localcomm = kcom
1237	!
1238	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1239	!
1240	ktab = iwork
1241	!
1242	END SUBROUTINE mppmax_int
1243
1244
1245	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1246	!!----------------------------------------------------------------------
1247	!! * routine mppmin_a_int *
1248	!!
1249	!! ** Purpose : Find minimum value in an integer layout array
1250	!!
1251	!!----------------------------------------------------------------------
1252	INTEGER , INTENT( in ) :: kdim ! size of array
1253	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1254	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
1255	!!
1256	INTEGER :: ierror, localcomm ! temporary integer
1257	INTEGER, DIMENSION(kdim) :: iwork
1258	!!----------------------------------------------------------------------
1259	!
1260	localcomm = mpi_comm_opa
1261	IF( PRESENT(kcom) ) localcomm = kcom
1262	!
1263	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1264	!
1265	ktab(:) = iwork(:)
1266	!
1267	END SUBROUTINE mppmin_a_int
1268
1269
1270	SUBROUTINE mppmin_int( ktab, kcom )
1271	!!----------------------------------------------------------------------
1272	!! * routine mppmin_int *
1273	!!
1274	!! ** Purpose : Find minimum value in an integer layout array
1275	!!
1276	!!----------------------------------------------------------------------
1277	INTEGER, INTENT(inout) :: ktab ! ???
1278	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
1279	!!
1280	INTEGER :: ierror, iwork, localcomm
1281	!!----------------------------------------------------------------------
1282	!
1283	localcomm = mpi_comm_opa
1284	IF( PRESENT(kcom) ) localcomm = kcom
1285	!
1286	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1287	!
1288	ktab = iwork
1289	!
1290	END SUBROUTINE mppmin_int
1291
1292
1293	SUBROUTINE mppsum_a_int( ktab, kdim )
1294	!!----------------------------------------------------------------------
1295	!! * routine mppsum_a_int *
1296	!!
1297	!! ** Purpose : Global integer sum, 1D array case
1298	!!
1299	!!----------------------------------------------------------------------
1300	INTEGER, INTENT(in ) :: kdim ! ???
1301	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
1302	!!
1303	INTEGER :: ierror
1304	INTEGER, DIMENSION (kdim) :: iwork
1305	!!----------------------------------------------------------------------
1306	!
1307	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1308	!
1309	ktab(:) = iwork(:)
1310	!
1311	END SUBROUTINE mppsum_a_int
1312
1313
1314	SUBROUTINE mppsum_int( ktab )
1315	!!----------------------------------------------------------------------
1316	!! * routine mppsum_int *
1317	!!
1318	!! ** Purpose : Global integer sum
1319	!!
1320	!!----------------------------------------------------------------------
1321	INTEGER, INTENT(inout) :: ktab
1322	!!
1323	INTEGER :: ierror, iwork
1324	!!----------------------------------------------------------------------
1325	!
1326	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1327	!
1328	ktab = iwork
1329	!
1330	END SUBROUTINE mppsum_int
1331
1332
1333	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1334	!!----------------------------------------------------------------------
1335	!! * routine mppmax_a_real *
1336	!!
1337	!! ** Purpose : Maximum
1338	!!
1339	!!----------------------------------------------------------------------
1340	INTEGER , INTENT(in ) :: kdim
1341	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
1342	INTEGER , INTENT(in ), OPTIONAL :: kcom
1343	!!
1344	INTEGER :: ierror, localcomm
1345	REAL(wp), DIMENSION(kdim) :: zwork
1346	!!----------------------------------------------------------------------
1347	!
1348	localcomm = mpi_comm_opa
1349	IF( PRESENT(kcom) ) localcomm = kcom
1350	!
1351	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1352	ptab(:) = zwork(:)
1353	!
1354	END SUBROUTINE mppmax_a_real
1355
1356
1357	SUBROUTINE mppmax_real( ptab, kcom )
1358	!!----------------------------------------------------------------------
1359	!! * routine mppmax_real *
1360	!!
1361	!! ** Purpose : Maximum
1362	!!
1363	!!----------------------------------------------------------------------
1364	REAL(wp), INTENT(inout) :: ptab ! ???
1365	INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???
1366	!!
1367	INTEGER :: ierror, localcomm
1368	REAL(wp) :: zwork
1369	!!----------------------------------------------------------------------
1370	!
1371	localcomm = mpi_comm_opa
1372	IF( PRESENT(kcom) ) localcomm = kcom
1373	!
1374	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1375	ptab = zwork
1376	!
1377	END SUBROUTINE mppmax_real
1378
1379
1380	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1381	!!----------------------------------------------------------------------
1382	!! * routine mppmin_a_real *
1383	!!
1384	!! ** Purpose : Minimum of REAL, array case
1385	!!
1386	!!-----------------------------------------------------------------------
1387	INTEGER , INTENT(in ) :: kdim
1388	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
1389	INTEGER , INTENT(in ), OPTIONAL :: kcom
1390	!!
1391	INTEGER :: ierror, localcomm
1392	REAL(wp), DIMENSION(kdim) :: zwork
1393	!!-----------------------------------------------------------------------
1394	!
1395	localcomm = mpi_comm_opa
1396	IF( PRESENT(kcom) ) localcomm = kcom
1397	!
1398	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1399	ptab(:) = zwork(:)
1400	!
1401	END SUBROUTINE mppmin_a_real
1402
1403
1404	SUBROUTINE mppmin_real( ptab, kcom )
1405	!!----------------------------------------------------------------------
1406	!! * routine mppmin_real *
1407	!!
1408	!! ** Purpose : minimum of REAL, scalar case
1409	!!
1410	!!-----------------------------------------------------------------------
1411	REAL(wp), INTENT(inout) :: ptab !
1412	INTEGER , INTENT(in ), OPTIONAL :: kcom
1413	!!
1414	INTEGER :: ierror
1415	REAL(wp) :: zwork
1416	INTEGER :: localcomm
1417	!!-----------------------------------------------------------------------
1418	!
1419	localcomm = mpi_comm_opa
1420	IF( PRESENT(kcom) ) localcomm = kcom
1421	!
1422	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1423	ptab = zwork
1424	!
1425	END SUBROUTINE mppmin_real
1426
1427
1428	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1429	!!----------------------------------------------------------------------
1430	!! * routine mppsum_a_real *
1431	!!
1432	!! ** Purpose : global sum, REAL ARRAY argument case
1433	!!
1434	!!-----------------------------------------------------------------------
1435	INTEGER , INTENT( in ) :: kdim ! size of ptab
1436	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
1437	INTEGER , INTENT( in ), OPTIONAL :: kcom
1438	!!
1439	INTEGER :: ierror ! temporary integer
1440	INTEGER :: localcomm
1441	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
1442	!!-----------------------------------------------------------------------
1443	!
1444	localcomm = mpi_comm_opa
1445	IF( PRESENT(kcom) ) localcomm = kcom
1446	!
1447	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1448	ptab(:) = zwork(:)
1449	!
1450	END SUBROUTINE mppsum_a_real
1451
1452
1453	SUBROUTINE mppsum_real( ptab, kcom )
1454	!!----------------------------------------------------------------------
1455	!! * routine mppsum_real *
1456	!!
1457	!! ** Purpose : global sum, SCALAR argument case
1458	!!
1459	!!-----------------------------------------------------------------------
1460	REAL(wp), INTENT(inout) :: ptab ! input scalar
1461	INTEGER , INTENT(in ), OPTIONAL :: kcom
1462	!!
1463	INTEGER :: ierror, localcomm
1464	REAL(wp) :: zwork
1465	!!-----------------------------------------------------------------------
1466	!
1467	localcomm = mpi_comm_opa
1468	IF( PRESENT(kcom) ) localcomm = kcom
1469	!
1470	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1471	ptab = zwork
1472	!
1473	END SUBROUTINE mppsum_real
1474
1475	# if defined key_mpp_rep
1476	SUBROUTINE mppsum_realdd( ytab, kcom )
1477	!!----------------------------------------------------------------------
1478	!! * routine mppsum_realdd *
1479	!!
1480	!! ** Purpose : global sum in Massively Parallel Processing
1481	!! SCALAR argument case for double-double precision
1482	!!
1483	!!-----------------------------------------------------------------------
1484	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
1485	INTEGER , INTENT( in ), OPTIONAL :: kcom
1486
1487	!! * Local variables (MPI version)
1488	INTEGER :: ierror
1489	INTEGER :: localcomm
1490	COMPLEX(wp) :: zwork
1491
1492	localcomm = mpi_comm_opa
1493	IF( PRESENT(kcom) ) localcomm = kcom
1494
1495	! reduce local sums into global sum
1496	CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, &
1497	MPI_SUMDD,localcomm,ierror)
1498	ytab = zwork
1499
1500	END SUBROUTINE mppsum_realdd
1501
1502
1503	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
1504	!!----------------------------------------------------------------------
1505	!! * routine mppsum_a_realdd *
1506	!!
1507	!! ** Purpose : global sum in Massively Parallel Processing
1508	!! COMPLEX ARRAY case for double-double precision
1509	!!
1510	!!-----------------------------------------------------------------------
1511	INTEGER , INTENT( in ) :: kdim ! size of ytab
1512	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
1513	INTEGER , INTENT( in ), OPTIONAL :: kcom
1514
1515	!! * Local variables (MPI version)
1516	INTEGER :: ierror ! temporary integer
1517	INTEGER :: localcomm
1518	COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace
1519
1520	localcomm = mpi_comm_opa
1521	IF( PRESENT(kcom) ) localcomm = kcom
1522
1523	CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, &
1524	MPI_SUMDD,localcomm,ierror)
1525	ytab(:) = zwork(:)
1526
1527	END SUBROUTINE mppsum_a_realdd
1528	# endif
1529
1530	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1531	!!------------------------------------------------------------------------
1532	!! * routine mpp_minloc *
1533	!!
1534	!! ** Purpose : Compute the global minimum of an array ptab
1535	!! and also give its global position
1536	!!
1537	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1538	!!
1539	!!--------------------------------------------------------------------------
1540	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
1541	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
1542	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
1543	INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame
1544	!!
1545	INTEGER , DIMENSION(2) :: ilocs
1546	INTEGER :: ierror
1547	REAL(wp) :: zmin ! local minimum
1548	REAL(wp), DIMENSION(2,1) :: zain, zaout
1549	!!-----------------------------------------------------------------------
1550	!
1551	zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
1552	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
1553	!
1554	ki = ilocs(1) + nimpp - 1
1555	kj = ilocs(2) + njmpp - 1
1556	!
1557	zain(1,:)=zmin
1558	zain(2,:)=ki+10000.*kj
1559	!
1560	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1561	!
1562	pmin = zaout(1,1)
1563	kj = INT(zaout(2,1)/10000.)
1564	ki = INT(zaout(2,1) - 10000.*kj )
1565	!
1566	END SUBROUTINE mpp_minloc2d
1567
1568
1569	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1570	!!------------------------------------------------------------------------
1571	!! * routine mpp_minloc *
1572	!!
1573	!! ** Purpose : Compute the global minimum of an array ptab
1574	!! and also give its global position
1575	!!
1576	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1577	!!
1578	!!--------------------------------------------------------------------------
1579	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array
1580	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask
1581	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
1582	INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame
1583	!!
1584	INTEGER :: ierror
1585	REAL(wp) :: zmin ! local minimum
1586	INTEGER , DIMENSION(3) :: ilocs
1587	REAL(wp), DIMENSION(2,1) :: zain, zaout
1588	!!-----------------------------------------------------------------------
1589	!
1590	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1591	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1592	!
1593	ki = ilocs(1) + nimpp - 1
1594	kj = ilocs(2) + njmpp - 1
1595	kk = ilocs(3)
1596	!
1597	zain(1,:)=zmin
1598	zain(2,:)=ki+10000.kj+100000000.kk
1599	!
1600	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1601	!
1602	pmin = zaout(1,1)
1603	kk = INT( zaout(2,1) / 100000000. )
1604	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
1605	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1606	!
1607	END SUBROUTINE mpp_minloc3d
1608
1609
1610	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1611	!!------------------------------------------------------------------------
1612	!! * routine mpp_maxloc *
1613	!!
1614	!! ** Purpose : Compute the global maximum of an array ptab
1615	!! and also give its global position
1616	!!
1617	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1618	!!
1619	!!--------------------------------------------------------------------------
1620	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
1621	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
1622	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
1623	INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame
1624	!!
1625	INTEGER :: ierror
1626	INTEGER, DIMENSION (2) :: ilocs
1627	REAL(wp) :: zmax ! local maximum
1628	REAL(wp), DIMENSION(2,1) :: zain, zaout
1629	!!-----------------------------------------------------------------------
1630	!
1631	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
1632	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
1633	!
1634	ki = ilocs(1) + nimpp - 1
1635	kj = ilocs(2) + njmpp - 1
1636	!
1637	zain(1,:) = zmax
1638	zain(2,:) = ki + 10000. * kj
1639	!
1640	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1641	!
1642	pmax = zaout(1,1)
1643	kj = INT( zaout(2,1) / 10000. )
1644	ki = INT( zaout(2,1) - 10000.* kj )
1645	!
1646	END SUBROUTINE mpp_maxloc2d
1647
1648
1649	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
1650	!!------------------------------------------------------------------------
1651	!! * routine mpp_maxloc *
1652	!!
1653	!! ** Purpose : Compute the global maximum of an array ptab
1654	!! and also give its global position
1655	!!
1656	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1657	!!
1658	!!--------------------------------------------------------------------------
1659	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array
1660	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask
1661	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
1662	INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame
1663	!!
1664	REAL(wp) :: zmax ! local maximum
1665	REAL(wp), DIMENSION(2,1) :: zain, zaout
1666	INTEGER , DIMENSION(3) :: ilocs
1667	INTEGER :: ierror
1668	!!-----------------------------------------------------------------------
1669	!
1670	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1671	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1672	!
1673	ki = ilocs(1) + nimpp - 1
1674	kj = ilocs(2) + njmpp - 1
1675	kk = ilocs(3)
1676	!
1677	zain(1,:)=zmax
1678	zain(2,:)=ki+10000.kj+100000000.kk
1679	!
1680	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1681	!
1682	pmax = zaout(1,1)
1683	kk = INT( zaout(2,1) / 100000000. )
1684	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
1685	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1686	!
1687	END SUBROUTINE mpp_maxloc3d
1688
1689
1690	SUBROUTINE mppsync()
1691	!!----------------------------------------------------------------------
1692	!! * routine mppsync *
1693	!!
1694	!! ** Purpose : Massively parallel processors, synchroneous
1695	!!
1696	!!-----------------------------------------------------------------------
1697	INTEGER :: ierror
1698	!!-----------------------------------------------------------------------
1699	!
1700	CALL mpi_barrier( mpi_comm_opa, ierror )
1701	!
1702	END SUBROUTINE mppsync
1703
1704
1705	SUBROUTINE mppstop
1706	!!----------------------------------------------------------------------
1707	!! * routine mppstop *
1708	!!
1709	!! ** purpose : Stop massilively parallel processors method
1710	!!
1711	!!----------------------------------------------------------------------
1712	INTEGER :: info
1713	!!----------------------------------------------------------------------
1714	!
1715	CALL mppsync
1716	CALL mpi_finalize( info )
1717	!
1718	END SUBROUTINE mppstop
1719
1720
1721	SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout)
1722	!!----------------------------------------------------------------------
1723	!! * routine mppobc *
1724	!!
1725	!! ** Purpose : Message passing manadgement for open boundary
1726	!! conditions array
1727	!!
1728	!! ** Method : Use mppsend and mpprecv function for passing mask
1729	!! between processors following neighboring subdomains.
1730	!! domain parameters
1731	!! nlci : first dimension of the local subdomain
1732	!! nlcj : second dimension of the local subdomain
1733	!! nbondi : mark for "east-west local boundary"
1734	!! nbondj : mark for "north-south local boundary"
1735	!! noea : number for local neighboring processors
1736	!! nowe : number for local neighboring processors
1737	!! noso : number for local neighboring processors
1738	!! nono : number for local neighboring processors
1739	!!
1740	!!----------------------------------------------------------------------
1741	USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
1742	USE wrk_nemo, ONLY: ztab => wrk_2d_1
1743	!
1744	INTEGER , INTENT(in ) :: kd1, kd2 ! starting and ending indices
1745	INTEGER , INTENT(in ) :: kl ! index of open boundary
1746	INTEGER , INTENT(in ) :: kk ! vertical dimension
1747	INTEGER , INTENT(in ) :: ktype ! define north/south or east/west cdt
1748	! ! = 1 north/south ; = 2 east/west
1749	INTEGER , INTENT(in ) :: kij ! horizontal dimension
1750	INTEGER , INTENT(in ) :: kumout ! ocean.output logical unit
1751	REAL(wp), INTENT(inout), DIMENSION(kij,kk) :: ptab ! variable array
1752	!
1753	INTEGER :: ji, jj, jk, jl ! dummy loop indices
1754	INTEGER :: iipt0, iipt1, ilpt1 ! local integers
1755	INTEGER :: ijpt0, ijpt1 ! - -
1756	INTEGER :: imigr, iihom, ijhom ! - -
1757	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1758	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
1759	!!----------------------------------------------------------------------
1760
1761	IF( wrk_in_use(2, 1) ) THEN
1762	WRITE(kumout, cform_err)
1763	WRITE(kumout,*) 'mppobc : requested workspace array unavailable'
1764	CALL mppstop
1765	ENDIF
1766
1767	! boundary condition initialization
1768	! ---------------------------------
1769	ztab(:,:) = 0.e0
1770	!
1771	IF( ktype==1 ) THEN ! north/south boundaries
1772	iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )
1773	iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
1774	ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )
1775	ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )
1776	ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )
1777	ELSEIF( ktype==2 ) THEN ! east/west boundaries
1778	iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )
1779	iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )
1780	ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )
1781	ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
1782	ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )
1783	ELSE
1784	WRITE(kumout, cform_err)
1785	WRITE(kumout,*) 'mppobc : bad ktype'
1786	CALL mppstop
1787	ENDIF
1788
1789	! Communication level by level
1790	! ----------------------------
1791	!!gm Remark : this is very time consumming!!!
1792	! ! ------------------------ !
1793	DO jk = 1, kk ! Loop over the levels !
1794	! ! ------------------------ !
1795	!
1796	IF( ktype == 1 ) THEN ! north/south boundaries
1797	DO jj = ijpt0, ijpt1
1798	DO ji = iipt0, iipt1
1799	ztab(ji,jj) = ptab(ji,jk)
1800	END DO
1801	END DO
1802	ELSEIF( ktype == 2 ) THEN ! east/west boundaries
1803	DO jj = ijpt0, ijpt1
1804	DO ji = iipt0, iipt1
1805	ztab(ji,jj) = ptab(jj,jk)
1806	END DO
1807	END DO
1808	ENDIF
1809
1810
1811	! 1. East and west directions
1812	! ---------------------------
1813	!
1814	IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions
1815	iihom = nlci-nreci
1816	DO jl = 1, jpreci
1817	t2ew(:,jl,1) = ztab(jpreci+jl,:)
1818	t2we(:,jl,1) = ztab(iihom +jl,:)
1819	END DO
1820	ENDIF
1821	!
1822	! ! Migrations
1823	imigr=jpreci*jpj
1824	!
1825	IF( nbondi == -1 ) THEN
1826	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1827	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1828	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1829	ELSEIF( nbondi == 0 ) THEN
1830	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1831	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1832	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1833	CALL mpprecv( 2, t2we(1,1,2), imigr )
1834	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1835	IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )
1836	ELSEIF( nbondi == 1 ) THEN
1837	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1838	CALL mpprecv( 2, t2we(1,1,2), imigr )
1839	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1840	ENDIF
1841	!
1842	! ! Write Dirichlet lateral conditions
1843	iihom = nlci-jpreci
1844	!
1845	IF( nbondi == 0 .OR. nbondi == 1 ) THEN
1846	DO jl = 1, jpreci
1847	ztab(jl,:) = t2we(:,jl,2)
1848	END DO
1849	ENDIF
1850	IF( nbondi == -1 .OR. nbondi == 0 ) THEN
1851	DO jl = 1, jpreci
1852	ztab(iihom+jl,:) = t2ew(:,jl,2)
1853	END DO
1854	ENDIF
1855
1856
1857	! 2. North and south directions
1858	! -----------------------------
1859	!
1860	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
1861	ijhom = nlcj-nrecj
1862	DO jl = 1, jprecj
1863	t2sn(:,jl,1) = ztab(:,ijhom +jl)
1864	t2ns(:,jl,1) = ztab(:,jprecj+jl)
1865	END DO
1866	ENDIF
1867	!
1868	! ! Migrations
1869	imigr = jprecj * jpi
1870	!
1871	IF( nbondj == -1 ) THEN
1872	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1873	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1874	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1875	ELSEIF( nbondj == 0 ) THEN
1876	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1877	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1878	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1879	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1880	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1881	IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
1882	ELSEIF( nbondj == 1 ) THEN
1883	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1884	CALL mpprecv( 4, t2sn(1,1,2), imigr)
1885	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1886	ENDIF
1887	!
1888	! ! Write Dirichlet lateral conditions
1889	ijhom = nlcj - jprecj
1890	IF( nbondj == 0 .OR. nbondj == 1 ) THEN
1891	DO jl = 1, jprecj
1892	ztab(:,jl) = t2sn(:,jl,2)
1893	END DO
1894	ENDIF
1895	IF( nbondj == 0 .OR. nbondj == -1 ) THEN
1896	DO jl = 1, jprecj
1897	ztab(:,ijhom+jl) = t2ns(:,jl,2)
1898	END DO
1899	ENDIF
1900	IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
1901	DO jj = ijpt0, ijpt1 ! north/south boundaries
1902	DO ji = iipt0,ilpt1
1903	ptab(ji,jk) = ztab(ji,jj)
1904	END DO
1905	END DO
1906	ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
1907	DO jj = ijpt0, ilpt1 ! east/west boundaries
1908	DO ji = iipt0,iipt1
1909	ptab(jj,jk) = ztab(ji,jj)
1910	END DO
1911	END DO
1912	ENDIF
1913	!
1914	END DO
1915	!
1916	IF( wrk_not_released(2, 1) ) THEN
1917	WRITE(kumout, cform_err)
1918	WRITE(kumout,*) 'mppobc : failed to release workspace array'
1919	CALL mppstop
1920	ENDIF
1921	!
1922	END SUBROUTINE mppobc
1923
1924
1925	SUBROUTINE mpp_comm_free( kcom )
1926	!!----------------------------------------------------------------------
1927	!!----------------------------------------------------------------------
1928	INTEGER, INTENT(in) :: kcom
1929	!!
1930	INTEGER :: ierr
1931	!!----------------------------------------------------------------------
1932	!
1933	CALL MPI_COMM_FREE(kcom, ierr)
1934	!
1935	END SUBROUTINE mpp_comm_free
1936
1937
1938	SUBROUTINE mpp_ini_ice( pindic, kumout )
1939	!!----------------------------------------------------------------------
1940	!! * routine mpp_ini_ice *
1941	!!
1942	!! ** Purpose : Initialize special communicator for ice areas
1943	!! condition together with global variables needed in the ddmpp folding
1944	!!
1945	!! ** Method : - Look for ice processors in ice routines
1946	!! - Put their number in nrank_ice
1947	!! - Create groups for the world processors and the ice processors
1948	!! - Create a communicator for ice processors
1949	!!
1950	!! ** output
1951	!! njmppmax = njmpp for northern procs
1952	!! ndim_rank_ice = number of processors with ice
1953	!! nrank_ice (ndim_rank_ice) = ice processors
1954	!! ngrp_world = group ID for the world processors
1955	!! ngrp_ice = group ID for the ice processors
1956	!! ncomm_ice = communicator for the ice procs.
1957	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
1958	!!
1959	!!----------------------------------------------------------------------
1960	INTEGER, INTENT(in) :: pindic
1961	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
1962	!!
1963	INTEGER :: jjproc
1964	INTEGER :: ii, ierr
1965	INTEGER, ALLOCATABLE, DIMENSION(:) :: kice
1966	INTEGER, ALLOCATABLE, DIMENSION(:) :: zwork
1967	!!----------------------------------------------------------------------
1968	!
1969	! Since this is just an init routine and these arrays are of length jpnij
1970	! then don't use wrk_nemo module - just allocate and deallocate.
1971	ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
1972	IF( ierr /= 0 ) THEN
1973	WRITE(kumout, cform_err)
1974	WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
1975	CALL mppstop
1976	ENDIF
1977
1978	! Look for how many procs with sea-ice
1979	!
1980	kice = 0
1981	DO jjproc = 1, jpnij
1982	IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1
1983	END DO
1984	!
1985	zwork = 0
1986	CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
1987	ndim_rank_ice = SUM( zwork )
1988
1989	! Allocate the right size to nrank_north
1990	#if ! defined key_agrif
1991	IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice )
1992	#else
1993	IF( ASSOCIATED( nrank_ice ) ) DEALLOCATE( nrank_ice )
1994	#endif
1995	ALLOCATE( nrank_ice(ndim_rank_ice) )
1996	!
1997	ii = 0
1998	nrank_ice = 0
1999	DO jjproc = 1, jpnij
2000	IF( zwork(jjproc) == 1) THEN
2001	ii = ii + 1
2002	nrank_ice(ii) = jjproc -1
2003	ENDIF
2004	END DO
2005
2006	! Create the world group
2007	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2008
2009	! Create the ice group from the world group
2010	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2011
2012	! Create the ice communicator , ie the pool of procs with sea-ice
2013	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2014
2015	! Find proc number in the world of proc 0 in the north
2016	! The following line seems to be useless, we just comment & keep it as reminder
2017	! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
2018	!
2019	DEALLOCATE(kice, zwork)
2020	!
2021	END SUBROUTINE mpp_ini_ice
2022
2023
2024	SUBROUTINE mpp_ini_znl( kumout )
2025	!!----------------------------------------------------------------------
2026	!! * routine mpp_ini_znl *
2027	!!
2028	!! ** Purpose : Initialize special communicator for computing zonal sum
2029	!!
2030	!! ** Method : - Look for processors in the same row
2031	!! - Put their number in nrank_znl
2032	!! - Create group for the znl processors
2033	!! - Create a communicator for znl processors
2034	!! - Determine if processor should write znl files
2035	!!
2036	!! ** output
2037	!! ndim_rank_znl = number of processors on the same row
2038	!! ngrp_znl = group ID for the znl processors
2039	!! ncomm_znl = communicator for the ice procs.
2040	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
2041	!!
2042	!!----------------------------------------------------------------------
2043	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
2044	!
2045	INTEGER :: jproc ! dummy loop integer
2046	INTEGER :: ierr, ii ! local integer
2047	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
2048	!!----------------------------------------------------------------------
2049	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
2050	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2051	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa : ', mpi_comm_opa
2052	!
2053	ALLOCATE( kwork(jpnij), STAT=ierr )
2054	IF( ierr /= 0 ) THEN
2055	WRITE(kumout, cform_err)
2056	WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2057	CALL mppstop
2058	ENDIF
2059
2060	IF( jpnj == 1 ) THEN
2061	ngrp_znl = ngrp_world
2062	ncomm_znl = mpi_comm_opa
2063	ELSE
2064	!
2065	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2066	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2067	!-$$ CALL flush(numout)
2068	!
2069	! Count number of processors on the same row
2070	ndim_rank_znl = 0
2071	DO jproc=1,jpnij
2072	IF ( kwork(jproc) == njmpp ) THEN
2073	ndim_rank_znl = ndim_rank_znl + 1
2074	ENDIF
2075	END DO
2076	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2077	!-$$ CALL flush(numout)
2078	! Allocate the right size to nrank_znl
2079	#if ! defined key_agrif
2080	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2081	#else
2082	IF (ASSOCIATED(nrank_znl)) DEALLOCATE(nrank_znl)
2083	#endif
2084	ALLOCATE(nrank_znl(ndim_rank_znl))
2085	ii = 0
2086	nrank_znl (:) = 0
2087	DO jproc=1,jpnij
2088	IF ( kwork(jproc) == njmpp) THEN
2089	ii = ii + 1
2090	nrank_znl(ii) = jproc -1
2091	ENDIF
2092	END DO
2093	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2094	!-$$ CALL flush(numout)
2095
2096	! Create the opa group
2097	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2098	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2099	!-$$ CALL flush(numout)
2100
2101	! Create the znl group from the opa group
2102	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2103	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2104	!-$$ CALL flush(numout)
2105
2106	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2107	CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2108	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2109	!-$$ CALL flush(numout)
2110	!
2111	END IF
2112
2113	! Determines if processor if the first (starting from i=1) on the row
2114	IF ( jpni == 1 ) THEN
2115	l_znl_root = .TRUE.
2116	ELSE
2117	l_znl_root = .FALSE.
2118	kwork (1) = nimpp
2119	CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2120	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2121	END IF
2122
2123	DEALLOCATE(kwork)
2124
2125	END SUBROUTINE mpp_ini_znl
2126
2127
2128	SUBROUTINE mpp_ini_north
2129	!!----------------------------------------------------------------------
2130	!! * routine mpp_ini_north *
2131	!!
2132	!! ** Purpose : Initialize special communicator for north folding
2133	!! condition together with global variables needed in the mpp folding
2134	!!
2135	!! ** Method : - Look for northern processors
2136	!! - Put their number in nrank_north
2137	!! - Create groups for the world processors and the north processors
2138	!! - Create a communicator for northern processors
2139	!!
2140	!! ** output
2141	!! njmppmax = njmpp for northern procs
2142	!! ndim_rank_north = number of processors in the northern line
2143	!! nrank_north (ndim_rank_north) = number of the northern procs.
2144	!! ngrp_world = group ID for the world processors
2145	!! ngrp_north = group ID for the northern processors
2146	!! ncomm_north = communicator for the northern procs.
2147	!! north_root = number (in the world) of proc 0 in the northern comm.
2148	!!
2149	!!----------------------------------------------------------------------
2150	INTEGER :: ierr
2151	INTEGER :: jjproc
2152	INTEGER :: ii, ji
2153	!!----------------------------------------------------------------------
2154	!
2155	njmppmax = MAXVAL( njmppt )
2156	!
2157	! Look for how many procs on the northern boundary
2158	ndim_rank_north = 0
2159	DO jjproc = 1, jpnij
2160	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
2161	END DO
2162	!
2163	! Allocate the right size to nrank_north
2164	#if ! defined key_agrif
2165	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2166	#else
2167	IF (ASSOCIATED(nrank_north)) DEALLOCATE(nrank_north)
2168	#endif
2169	ALLOCATE( nrank_north(ndim_rank_north) )
2170
2171	! Fill the nrank_north array with proc. number of northern procs.
2172	! Note : the rank start at 0 in MPI
2173	ii = 0
2174	DO ji = 1, jpnij
2175	IF ( njmppt(ji) == njmppmax ) THEN
2176	ii=ii+1
2177	nrank_north(ii)=ji-1
2178	END IF
2179	END DO
2180	!
2181	! create the world group
2182	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2183	!
2184	! Create the North group from the world group
2185	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2186	!
2187	! Create the North communicator , ie the pool of procs in the north group
2188	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2189	!
2190	END SUBROUTINE mpp_ini_north
2191
2192
2193	SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2194	!!---------------------------------------------------------------------
2195	!! * routine mpp_lbc_north_3d *
2196	!!
2197	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2198	!! in mpp configuration in case of jpn1 > 1
2199	!!
2200	!! ** Method : North fold condition and mpp with more than one proc
2201	!! in i-direction require a specific treatment. We gather
2202	!! the 4 northern lines of the global domain on 1 processor
2203	!! and apply lbc north-fold on this sub array. Then we
2204	!! scatter the north fold array back to the processors.
2205	!!
2206	!!----------------------------------------------------------------------
2207	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied
2208	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
2209	! ! = T , U , V , F or W gridpoints
2210	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
2211	!! ! = 1. , the sign is kept
2212	INTEGER :: ji, jj, jr
2213	INTEGER :: ierr, itaille, ildi, ilei, iilb
2214	INTEGER :: ijpj, ijpjm1, ij, iproc
2215	!!----------------------------------------------------------------------
2216	!
2217	ijpj = 4
2218	ijpjm1 = 3
2219	ztab(:,:,:) = 0.e0
2220	!
2221	DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d
2222	ij = jj - nlcj + ijpj
2223	znorthloc(:,ij,:) = pt3d(:,jj,:)
2224	END DO
2225	!
2226	! ! Build in procs of ncomm_north the znorthgloio
2227	itaille = jpi * jpk * ijpj
2228	CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &
2229	& znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2230	!
2231	! ! recover the global north array
2232	DO jr = 1, ndim_rank_north
2233	iproc = nrank_north(jr) + 1
2234	ildi = nldit (iproc)
2235	ilei = nleit (iproc)
2236	iilb = nimppt(iproc)
2237	DO jj = 1, 4
2238	DO ji = ildi, ilei
2239	ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
2240	END DO
2241	END DO
2242	END DO
2243	!
2244	CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
2245	!
2246	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
2247	ij = jj - nlcj + ijpj
2248	DO ji= 1, nlci
2249	pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)
2250	END DO
2251	END DO
2252	!
2253	END SUBROUTINE mpp_lbc_north_3d
2254
2255
2256	SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2257	!!---------------------------------------------------------------------
2258	!! * routine mpp_lbc_north_2d *
2259	!!
2260	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2261	!! in mpp configuration in case of jpn1 > 1 (for 2d array )
2262	!!
2263	!! ** Method : North fold condition and mpp with more than one proc
2264	!! in i-direction require a specific treatment. We gather
2265	!! the 4 northern lines of the global domain on 1 processor
2266	!! and apply lbc north-fold on this sub array. Then we
2267	!! scatter the north fold array back to the processors.
2268	!!
2269	!!----------------------------------------------------------------------
2270	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the b.c. is applied
2271	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
2272	! ! = T , U , V , F or W gridpoints
2273	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
2274	!! ! = 1. , the sign is kept
2275	INTEGER :: ji, jj, jr
2276	INTEGER :: ierr, itaille, ildi, ilei, iilb
2277	INTEGER :: ijpj, ijpjm1, ij, iproc
2278	!!----------------------------------------------------------------------
2279	!
2280	ijpj = 4
2281	ijpjm1 = 3
2282	ztab_2d(:,:) = 0.e0
2283	!
2284	DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc_2d the last 4 jlines of pt2d
2285	ij = jj - nlcj + ijpj
2286	znorthloc_2d(:,ij) = pt2d(:,jj)
2287	END DO
2288
2289	! ! Build in procs of ncomm_north the znorthgloio_2d
2290	itaille = jpi * ijpj
2291	CALL MPI_ALLGATHER( znorthloc_2d , itaille, MPI_DOUBLE_PRECISION, &
2292	& znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2293	!
2294	DO jr = 1, ndim_rank_north ! recover the global north array
2295	iproc = nrank_north(jr) + 1
2296	ildi=nldit (iproc)
2297	ilei=nleit (iproc)
2298	iilb=nimppt(iproc)
2299	DO jj = 1, 4
2300	DO ji = ildi, ilei
2301	ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr)
2302	END DO
2303	END DO
2304	END DO
2305	!
2306	CALL lbc_nfd( ztab_2d, cd_type, psgn ) ! North fold boundary condition
2307	!
2308	!
2309	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
2310	ij = jj - nlcj + ijpj
2311	DO ji = 1, nlci
2312	pt2d(ji,jj) = ztab_2d(ji+nimpp-1,ij)
2313	END DO
2314	END DO
2315	!
2316	END SUBROUTINE mpp_lbc_north_2d
2317
2318
2319	SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2320	!!---------------------------------------------------------------------
2321	!! * routine mpp_lbc_north_2d *
2322	!!
2323	!! ** Purpose : Ensure proper north fold horizontal bondary condition
2324	!! in mpp configuration in case of jpn1 > 1 and for 2d
2325	!! array with outer extra halo
2326	!!
2327	!! ** Method : North fold condition and mpp with more than one proc
2328	!! in i-direction require a specific treatment. We gather
2329	!! the 4+2*jpr2dj northern lines of the global domain on 1
2330	!! processor and apply lbc north-fold on this sub array.
2331	!! Then we scatter the north fold array back to the processors.
2332	!!
2333	!!----------------------------------------------------------------------
2334	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
2335	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
2336	! ! = T , U , V , F or W -points
2337	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
2338	!! ! north fold, = 1. otherwise
2339	INTEGER :: ji, jj, jr
2340	INTEGER :: ierr, itaille, ildi, ilei, iilb
2341	INTEGER :: ijpj, ij, iproc
2342	!!----------------------------------------------------------------------
2343	!
2344	ijpj=4
2345	ztab_e(:,:) = 0.e0
2346
2347	ij=0
2348	! put in znorthloc_e the last 4 jlines of pt2d
2349	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2350	ij = ij + 1
2351	DO ji = 1, jpi
2352	znorthloc_e(ji,ij)=pt2d(ji,jj)
2353	END DO
2354	END DO
2355	!
2356	itaille = jpi * ( ijpj + 2 * jpr2dj )
2357	CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
2358	& znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2359	!
2360	DO jr = 1, ndim_rank_north ! recover the global north array
2361	iproc = nrank_north(jr) + 1
2362	ildi = nldit (iproc)
2363	ilei = nleit (iproc)
2364	iilb = nimppt(iproc)
2365	DO jj = 1, ijpj+2*jpr2dj
2366	DO ji = ildi, ilei
2367	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2368	END DO
2369	END DO
2370	END DO
2371
2372
2373	! 2. North-Fold boundary conditions
2374	! ----------------------------------
2375	CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
2376
2377	ij = jpr2dj
2378	!! Scatter back to pt2d
2379	DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2380	ij = ij +1
2381	DO ji= 1, nlci
2382	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2383	END DO
2384	END DO
2385	!
2386	END SUBROUTINE mpp_lbc_north_e
2387
2388
2389	SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
2390	!!---------------------------------------------------------------------
2391	!! * routine mpp_init.opa *
2392	!!
2393	!! ** Purpose :: export and attach a MPI buffer for bsend
2394	!!
2395	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
2396	!! but classical mpi_init
2397	!!
2398	!! History :: 01/11 :: IDRIS initial version for IBM only
2399	!! 08/04 :: R. Benshila, generalisation
2400	!!---------------------------------------------------------------------
2401	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
2402	INTEGER , INTENT(inout) :: ksft
2403	INTEGER , INTENT( out) :: code
2404	INTEGER :: ierr, ji
2405	LOGICAL :: mpi_was_called
2406	!!---------------------------------------------------------------------
2407	!
2408	CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization
2409	IF ( code /= MPI_SUCCESS ) THEN
2410	DO ji = 1, SIZE(ldtxt)
2411	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
2412	END DO
2413	WRITE(*, cform_err)
2414	WRITE(, ) ' lib_mpp: Error in routine mpi_initialized'
2415	CALL mpi_abort( mpi_comm_world, code, ierr )
2416	ENDIF
2417	!
2418	IF( .NOT. mpi_was_called ) THEN
2419	CALL mpi_init( code )
2420	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
2421	IF ( code /= MPI_SUCCESS ) THEN
2422	DO ji = 1, SIZE(ldtxt)
2423	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
2424	END DO
2425	WRITE(*, cform_err)
2426	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
2427	CALL mpi_abort( mpi_comm_world, code, ierr )
2428	ENDIF
2429	ENDIF
2430	!
2431	IF( nn_buffer > 0 ) THEN
2432	WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1
2433	! Buffer allocation and attachment
2434	ALLOCATE( tampon(nn_buffer), stat = ierr )
2435	IF( ierr /= 0 ) THEN
2436	DO ji = 1, SIZE(ldtxt)
2437	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
2438	END DO
2439	WRITE(*, cform_err)
2440	WRITE(, ) ' lib_mpp: Error in ALLOCATE', ierr
2441	CALL mpi_abort( mpi_comm_world, code, ierr )
2442	END IF
2443	CALL mpi_buffer_attach( tampon, nn_buffer, code )
2444	ENDIF
2445	!
2446	END SUBROUTINE mpi_init_opa
2447
2448	#if defined key_mpp_rep
2449	SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
2450	!!---------------------------------------------------------------------
2451	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
2452	!!
2453	!! Modification of original codes written by David H. Bailey
2454	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
2455	!!---------------------------------------------------------------------
2456	INTEGER, INTENT(in) :: ilen, itype
2457	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
2458	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
2459	!
2460	REAL(wp) :: zerr, zt1, zt2 ! local work variables
2461	INTEGER :: ji, ztmp ! local scalar
2462
2463	ztmp = itype ! avoid compilation warning
2464
2465	DO ji=1,ilen
2466	! Compute ydda + yddb using Knuth's trick.
2467	zt1 = real(ydda(ji)) + real(yddb(ji))
2468	zerr = zt1 - real(ydda(ji))
2469	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
2470	+ aimag(ydda(ji)) + aimag(yddb(ji))
2471
2472	! The result is zt1 + zt2, after normalization.
2473	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
2474	END DO
2475
2476	END SUBROUTINE DDPDD_MPI
2477	#endif
2478
2479	#else
2480	!!----------------------------------------------------------------------
2481	!! Default case: Dummy module share memory computing
2482	!!----------------------------------------------------------------------
2483	USE in_out_manager
2484
2485	INTERFACE mpp_sum
2486	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
2487	END INTERFACE
2488	INTERFACE mpp_max
2489	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
2490	END INTERFACE
2491	INTERFACE mpp_min
2492	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
2493	END INTERFACE
2494	INTERFACE mppobc
2495	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
2496	END INTERFACE
2497	INTERFACE mpp_minloc
2498	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
2499	END INTERFACE
2500	INTERFACE mpp_maxloc
2501	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
2502	END INTERFACE
2503
2504	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
2505	INTEGER :: ncomm_ice
2506	!!----------------------------------------------------------------------
2507	CONTAINS
2508
2509	INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function
2510	INTEGER, INTENT(in) :: kumout
2511	lib_mpp_alloc = 0
2512	END FUNCTION lib_mpp_alloc
2513
2514	FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) RESULT (function_value)
2515	INTEGER, OPTIONAL , INTENT(in ) :: localComm
2516	CHARACTER(len=*),DIMENSION(:) :: ldtxt
2517	INTEGER :: kumnam, kstop
2518	IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0
2519	IF( .FALSE. ) ldtxt(:) = 'never done'
2520	END FUNCTION mynode
2521
2522	SUBROUTINE mppsync ! Dummy routine
2523	END SUBROUTINE mppsync
2524
2525	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
2526	REAL , DIMENSION(:) :: parr
2527	INTEGER :: kdim
2528	INTEGER, OPTIONAL :: kcom
2529	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
2530	END SUBROUTINE mpp_sum_as
2531
2532	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
2533	REAL , DIMENSION(:,:) :: parr
2534	INTEGER :: kdim
2535	INTEGER, OPTIONAL :: kcom
2536	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
2537	END SUBROUTINE mpp_sum_a2s
2538
2539	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
2540	INTEGER, DIMENSION(:) :: karr
2541	INTEGER :: kdim
2542	INTEGER, OPTIONAL :: kcom
2543	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
2544	END SUBROUTINE mpp_sum_ai
2545
2546	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
2547	REAL :: psca
2548	INTEGER, OPTIONAL :: kcom
2549	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
2550	END SUBROUTINE mpp_sum_s
2551
2552	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
2553	integer :: kint
2554	INTEGER, OPTIONAL :: kcom
2555	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
2556	END SUBROUTINE mpp_sum_i
2557
2558	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
2559	REAL , DIMENSION(:) :: parr
2560	INTEGER :: kdim
2561	INTEGER, OPTIONAL :: kcom
2562	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2563	END SUBROUTINE mppmax_a_real
2564
2565	SUBROUTINE mppmax_real( psca, kcom )
2566	REAL :: psca
2567	INTEGER, OPTIONAL :: kcom
2568	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
2569	END SUBROUTINE mppmax_real
2570
2571	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
2572	REAL , DIMENSION(:) :: parr
2573	INTEGER :: kdim
2574	INTEGER, OPTIONAL :: kcom
2575	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2576	END SUBROUTINE mppmin_a_real
2577
2578	SUBROUTINE mppmin_real( psca, kcom )
2579	REAL :: psca
2580	INTEGER, OPTIONAL :: kcom
2581	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
2582	END SUBROUTINE mppmin_real
2583
2584	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
2585	INTEGER, DIMENSION(:) :: karr
2586	INTEGER :: kdim
2587	INTEGER, OPTIONAL :: kcom
2588	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2589	END SUBROUTINE mppmax_a_int
2590
2591	SUBROUTINE mppmax_int( kint, kcom)
2592	INTEGER :: kint
2593	INTEGER, OPTIONAL :: kcom
2594	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
2595	END SUBROUTINE mppmax_int
2596
2597	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
2598	INTEGER, DIMENSION(:) :: karr
2599	INTEGER :: kdim
2600	INTEGER, OPTIONAL :: kcom
2601	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2602	END SUBROUTINE mppmin_a_int
2603
2604	SUBROUTINE mppmin_int( kint, kcom )
2605	INTEGER :: kint
2606	INTEGER, OPTIONAL :: kcom
2607	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
2608	END SUBROUTINE mppmin_int
2609
2610	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2611	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
2612	REAL, DIMENSION(:) :: parr ! variable array
2613	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum
2614	END SUBROUTINE mppobc_1d
2615
2616	SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2617	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
2618	REAL, DIMENSION(:,:) :: parr ! variable array
2619	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum
2620	END SUBROUTINE mppobc_2d
2621
2622	SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2623	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
2624	REAL, DIMENSION(:,:,:) :: parr ! variable array
2625	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
2626	END SUBROUTINE mppobc_3d
2627
2628	SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2629	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
2630	REAL, DIMENSION(:,:,:,:) :: parr ! variable array
2631	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
2632	END SUBROUTINE mppobc_4d
2633
2634	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
2635	REAL :: pmin
2636	REAL , DIMENSION (:,:) :: ptab, pmask
2637	INTEGER :: ki, kj
2638	WRITE(,) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
2639	END SUBROUTINE mpp_minloc2d
2640
2641	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
2642	REAL :: pmin
2643	REAL , DIMENSION (:,:,:) :: ptab, pmask
2644	INTEGER :: ki, kj, kk
2645	WRITE(,) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2646	END SUBROUTINE mpp_minloc3d
2647
2648	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2649	REAL :: pmax
2650	REAL , DIMENSION (:,:) :: ptab, pmask
2651	INTEGER :: ki, kj
2652	WRITE(,) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
2653	END SUBROUTINE mpp_maxloc2d
2654
2655	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2656	REAL :: pmax
2657	REAL , DIMENSION (:,:,:) :: ptab, pmask
2658	INTEGER :: ki, kj, kk
2659	WRITE(,) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2660	END SUBROUTINE mpp_maxloc3d
2661
2662	SUBROUTINE mppstop
2663	WRITE(,) 'mppstop: You should not have seen this print! error?'
2664	END SUBROUTINE mppstop
2665
2666	SUBROUTINE mpp_ini_ice( kcom, knum )
2667	INTEGER :: kcom, knum
2668	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
2669	END SUBROUTINE mpp_ini_ice
2670
2671	SUBROUTINE mpp_ini_znl( knum )
2672	INTEGER :: knum
2673	WRITE(,) 'mpp_ini_znl: You should not have seen this print! error?', knum
2674	END SUBROUTINE mpp_ini_znl
2675
2676	SUBROUTINE mpp_comm_free( kcom )
2677	INTEGER :: kcom
2678	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?', kcom
2679	END SUBROUTINE mpp_comm_free
2680	#endif
2681
2682	!!----------------------------------------------------------------------
2683	!! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn routines
2684	!!----------------------------------------------------------------------
2685
2686	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
2687	& cd6, cd7, cd8, cd9, cd10 )
2688	!!----------------------------------------------------------------------
2689	!! * ROUTINE stop_opa *
2690	!!
2691	!! ** Purpose : print in ocean.outpput file a error message and
2692	!! increment the error number (nstop) by one.
2693	!!----------------------------------------------------------------------
2694	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
2695	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
2696	!!----------------------------------------------------------------------
2697	!
2698	nstop = nstop + 1
2699	IF(lwp) THEN
2700	WRITE(numout,cform_err)
2701	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
2702	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
2703	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
2704	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
2705	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
2706	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
2707	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
2708	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
2709	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
2710	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
2711	ENDIF
2712	CALL FLUSH(numout )
2713	IF( numstp /= -1 ) CALL FLUSH(numstp )
2714	IF( numsol /= -1 ) CALL FLUSH(numsol )
2715	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
2716	!
2717	IF( cd1 == 'STOP' ) THEN
2718	IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
2719	CALL mppstop()
2720	ENDIF
2721	!
2722	END SUBROUTINE ctl_stop
2723
2724
2725	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
2726	& cd6, cd7, cd8, cd9, cd10 )
2727	!!----------------------------------------------------------------------
2728	!! * ROUTINE stop_warn *
2729	!!
2730	!! ** Purpose : print in ocean.outpput file a error message and
2731	!! increment the warning number (nwarn) by one.
2732	!!----------------------------------------------------------------------
2733	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
2734	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
2735	!!----------------------------------------------------------------------
2736	!
2737	nwarn = nwarn + 1
2738	IF(lwp) THEN
2739	WRITE(numout,cform_war)
2740	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
2741	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
2742	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
2743	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
2744	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
2745	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
2746	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
2747	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
2748	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
2749	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
2750	ENDIF
2751	CALL FLUSH(numout)
2752	!
2753	END SUBROUTINE ctl_warn
2754
2755
2756	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
2757	!!----------------------------------------------------------------------
2758	!! * ROUTINE ctl_opn *
2759	!!
2760	!! ** Purpose : Open file and check if required file is available.
2761	!!
2762	!! ** Method : Fortan open
2763	!!----------------------------------------------------------------------
2764	INTEGER , INTENT( out) :: knum ! logical unit to open
2765	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
2766	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
2767	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
2768	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
2769	INTEGER , INTENT(in ) :: klengh ! record length
2770	INTEGER , INTENT(in ) :: kout ! number of logical units for write
2771	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
2772	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
2773	!!
2774	CHARACTER(len=80) :: clfile
2775	INTEGER :: iost
2776	!!----------------------------------------------------------------------
2777
2778	! adapt filename
2779	! ----------------
2780	clfile = TRIM(cdfile)
2781	IF( PRESENT( karea ) ) THEN
2782	IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
2783	ENDIF
2784	#if defined key_agrif
2785	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
2786	knum=Agrif_Get_Unit()
2787	#else
2788	knum=get_unit()
2789	#endif
2790
2791	iost=0
2792	IF( cdacce(1:6) == 'DIRECT' ) THEN
2793	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
2794	ELSE
2795	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
2796	ENDIF
2797	IF( iost == 0 ) THEN
2798	IF(ldwp) THEN
2799	WRITE(kout,*) ' file : ', clfile,' open ok'
2800	WRITE(kout,*) ' unit = ', knum
2801	WRITE(kout,*) ' status = ', cdstat
2802	WRITE(kout,*) ' form = ', cdform
2803	WRITE(kout,*) ' access = ', cdacce
2804	WRITE(kout,*)
2805	ENDIF
2806	ENDIF
2807	100 CONTINUE
2808	IF( iost /= 0 ) THEN
2809	IF(ldwp) THEN
2810	WRITE(kout,*)
2811	WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
2812	WRITE(kout,*) ' ======= === '
2813	WRITE(kout,*) ' unit = ', knum
2814	WRITE(kout,*) ' status = ', cdstat
2815	WRITE(kout,*) ' form = ', cdform
2816	WRITE(kout,*) ' access = ', cdacce
2817	WRITE(kout,*) ' iostat = ', iost
2818	WRITE(kout,*) ' we stop. verify the file '
2819	WRITE(kout,*)
2820	ENDIF
2821	STOP 'ctl_opn bad opening'
2822	ENDIF
2823
2824	END SUBROUTINE ctl_opn
2825
2826
2827	INTEGER FUNCTION get_unit()
2828	!!----------------------------------------------------------------------
2829	!! * FUNCTION get_unit *
2830	!!
2831	!! ** Purpose : return the index of an unused logical unit
2832	!!----------------------------------------------------------------------
2833	LOGICAL :: llopn
2834	!!----------------------------------------------------------------------
2835	!
2836	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
2837	llopn = .TRUE.
2838	DO WHILE( (get_unit < 998) .AND. llopn )
2839	get_unit = get_unit + 1
2840	INQUIRE( unit = get_unit, opened = llopn )
2841	END DO
2842	IF( (get_unit == 999) .AND. llopn ) THEN
2843	CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
2844	get_unit = -1
2845	ENDIF
2846	!
2847	END FUNCTION get_unit
2848
2849	!!----------------------------------------------------------------------
2850	END MODULE lib_mpp

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

Download in other formats: