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

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

lib_mpp.F90 in branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4328

Last change on this file since 4328 was 4328, checked in by davestorkey, 10 years ago
Remove OBC module at NEMO 3.6. See ticket #1189.
Property svn:keywords set to `Id`
File size: 137.1 KB

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

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

Download in other formats: