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

Context Navigation

source: branches/2012/dev_LOCEAN_UKMO_CMCC_INGV_2012/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 3666

Last change on this file since 3666 was 3666, checked in by cetlod, 11 years ago
commit the changes resulting for the merged branches, see ticket #1025
Property svn:keywords set to `Id`
File size: 161.1 KB

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

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

Download in other formats: