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

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

lib_mpp.F90 in branches/DEV_r2191_3partymerge2010/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/DEV_r2191_3partymerge2010/NEMO/OPA_SRC/lib_mpp.F90 @ 2207

Last change on this file since 2207 was 2207, checked in by acc, 14 years ago
#733 DEV_r2191_3partymerge2010. Merged in changes from devukmo2010 branch
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 104.2 KB

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

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

Download in other formats: