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

Context Navigation

source: branches/2013/dev_r3853_CNRS9_ConfSetting/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 3901

Last change on this file since 3901 was 3901, checked in by clevy, 11 years ago
Configuration Setting/Step2, see ticket:#1074
Property svn:keywords set to `Id`
File size: 162.2 KB

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

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

Download in other formats: