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 @ 2633

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

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

Download in other formats: