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

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

lib_mpp.F90 in branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 2636

Last change on this file since 2636 was 2636, checked in by gm, 13 years ago
dynamic mem: #785 ; move ctl_stop & warn in lib_mpp to avoid a circular dependency + ctl_stop improvment
Property svn:keywords set to `Id`
File size: 121.4 KB

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

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

Download in other formats: