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 trunk/NEMO/OPA_SRC – NEMO

Context Navigation

source: trunk/NEMO/OPA_SRC/lib_mpp.F90 @ 1502

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

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

Download in other formats: