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

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

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

Context Navigation

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

Last change on this file since 2731 was 2731, checked in by rblod, 13 years ago
Changes for Agrif in MPI
Property svn:keywords set to `Id`
File size: 122.0 KB

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

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

Download in other formats: