Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

lib_mpp.F90 @ 8243

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

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

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

Context Navigation

source: branches/UKMO/test_moci_test_suite/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8243

Download in other formats: