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 @ 2620

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

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

Download in other formats: