Context Navigation

lib_mpp.F90 @ 8879

Last change on this file since 8879 was 8879, checked in by frrh, 6 years ago
Merge in http://fcm3/projects/NEMO.xm/log/branches/UKMO/dev_r8183_ICEMODEL_svn_removed revisions 8738:8847 inclusive.
File size: 98.7 KB

Line
1	MODULE lib_mpp
2	!!======================================================================
3	!! * MODULE lib_mpp *
4	!! Ocean numerics: massively parallel processing library
5	!!=====================================================================
6	!! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) Original code
7	!! 7.0 ! 1997 (A.M. Treguier) SHMEM additions
8	!! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
9	!! ! 1998 (J.M. Molines) Open boundary conditions
10	!! NEMO 1.0 ! 2003 (J.M. Molines, G. Madec) F90, free form
11	!! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d)
12	!! - ! 2004 (R. Bourdalle Badie) isend option in mpi
13	!! ! 2004 (J.M. Molines) minloc, maxloc
14	!! - ! 2005 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
15	!! - ! 2005 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
16	!! - ! 2005 (R. Benshila, G. Madec) add extra halo case
17	!! - ! 2008 (R. Benshila) add mpp_ini_ice
18	!! 3.2 ! 2009 (R. Benshila) SHMEM suppression, north fold in lbc_nfd
19	!! 3.2 ! 2009 (O. Marti) add mpp_ini_znl
20	!! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager
21	!! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm.
22	!! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables
23	!! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
24	!! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max
25	!! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension)
26	!! - ! 2017 (G. Madec) create generic.h90 files to generate all lbc and north fold routines
27	!!----------------------------------------------------------------------
28
29	!!----------------------------------------------------------------------
30	!! ctl_stop : update momentum and tracer Kz from a tke scheme
31	!! ctl_warn : initialization, namelist read, and parameters control
32	!! ctl_opn : Open file and check if required file is available.
33	!! ctl_nam : Prints informations when an error occurs while reading a namelist
34	!! get_unit : give the index of an unused logical unit
35	!!----------------------------------------------------------------------
36	#if defined key_mpp_mpi
37	!!----------------------------------------------------------------------
38	!! 'key_mpp_mpi' MPI massively parallel processing library
39	!!----------------------------------------------------------------------
40	!! lib_mpp_alloc : allocate mpp arrays
41	!! mynode : indentify the processor unit
42	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
43	!! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
44	!! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
45	!! mpprecv :
46	!! mppsend :
47	!! mppscatter :
48	!! mppgather :
49	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
50	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
51	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
52	!! mpp_minloc :
53	!! mpp_maxloc :
54	!! mppsync :
55	!! mppstop :
56	!! mpp_ini_north : initialisation of north fold
57	!!gm !! mpp_lbc_north : north fold processors gathering
58	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
59	!! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs
60	!!----------------------------------------------------------------------
61	USE dom_oce ! ocean space and time domain
62	USE lbcnfd ! north fold treatment
63	USE in_out_manager ! I/O manager
64	USE wrk_nemo ! work arrays
65
66	IMPLICIT NONE
67	PRIVATE
68
69	INTERFACE mpp_nfd
70	MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d
71	MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
72	END INTERFACE
73
74	! Interface associated to the mpp_lnk_... routines is defined in lbclnk
75	PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d
76	PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr
77	PUBLIC mpp_lnk_2d_e
78	!
79	!!gm this should be useless
80	PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d
81	PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
82	!!gm end
83	!
84	PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam
85	PUBLIC mynode, mppstop, mppsync, mpp_comm_free
86	PUBLIC mpp_ini_north, mpp_lbc_north_e
87	!!gm PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
88	PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb
89	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
90	PUBLIC mpp_max_multiple
91	!!gm PUBLIC mpp_lnk_2d_9
92	!!gm PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d
93	PUBLIC mppscatter, mppgather
94	PUBLIC mpp_ini_ice, mpp_ini_znl
95	PUBLIC mppsize
96	PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines
97	PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
98	PUBLIC mpprank
99
100	!! * Interfaces
101	!! define generic interface for these routine as they are called sometimes
102	!! with scalar arguments instead of array arguments, which causes problems
103	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
104	INTERFACE mpp_min
105	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
106	END INTERFACE
107	INTERFACE mpp_max
108	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
109	END INTERFACE
110	INTERFACE mpp_sum
111	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
112	& mppsum_realdd, mppsum_a_realdd
113	END INTERFACE
114	!!gm INTERFACE mpp_lbc_north
115	!!gm MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
116	!!gm END INTERFACE
117	INTERFACE mpp_minloc
118	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
119	END INTERFACE
120	INTERFACE mpp_maxloc
121	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
122	END INTERFACE
123	INTERFACE mpp_max_multiple
124	MODULE PROCEDURE mppmax_real_multiple
125	END INTERFACE
126
127	!! ========================= !!
128	!! MPI variable definition !!
129	!! ========================= !!
130	!$AGRIF_DO_NOT_TREAT
131	INCLUDE 'mpif.h'
132	!$AGRIF_END_DO_NOT_TREAT
133
134	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
135
136	INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)
137
138	INTEGER :: mppsize ! number of process
139	INTEGER :: mpprank ! process number [ 0 - size-1 ]
140	!$AGRIF_DO_NOT_TREAT
141	INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator
142	!$AGRIF_END_DO_NOT_TREAT
143
144	INTEGER :: MPI_SUMDD
145
146	! variables used in case of sea-ice
147	INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in icethd)
148	INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology)
149	INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)
150	INTEGER :: ndim_rank_ice ! number of 'ice' processors
151	INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm
152	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice
153
154	! variables used for zonal integration
155	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
156	LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row
157	INTEGER :: ngrp_znl ! group ID for the znl processors
158	INTEGER :: ndim_rank_znl ! number of processors on the same zonal average
159	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain
160
161	! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
162	INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors
163	INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors
164	INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold)
165	INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north
166	INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !)
167	INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line
168	INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm
169	INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north
170
171	! Type of send : standard, buffered, immediate
172	CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend)
173	LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I')
174	INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend
175
176	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend
177
178	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms
179	LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms
180
181	!!----------------------------------------------------------------------
182	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
183	!! $Id$
184	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
185	!!----------------------------------------------------------------------
186	CONTAINS
187
188	FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm )
189	!!----------------------------------------------------------------------
190	!! * routine mynode *
191	!!
192	!! ** Purpose : Find processor unit
193	!!----------------------------------------------------------------------
194	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt !
195	CHARACTER(len=*) , INTENT(in ) :: ldname !
196	INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist
197	INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist
198	INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output
199	INTEGER , INTENT(inout) :: kstop ! stop indicator
200	INTEGER , OPTIONAL , INTENT(in ) :: localComm !
201	!
202	INTEGER :: mynode, ierr, code, ji, ii, ios
203	LOGICAL :: mpi_was_called
204	!
205	NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
206	!!----------------------------------------------------------------------
207	!
208	ii = 1
209	WRITE(ldtxt(ii),*) ; ii = ii + 1
210	WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1
211	WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1
212	!
213	REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables
214	READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901)
215	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp )
216	!
217	REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables
218	READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 )
219	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp )
220	!
221	! ! control print
222	WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1
223	WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
224	WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1
225	!
226	#if defined key_agrif
227	IF( .NOT. Agrif_Root() ) THEN
228	jpni = Agrif_Parent(jpni )
229	jpnj = Agrif_Parent(jpnj )
230	jpnij = Agrif_Parent(jpnij)
231	ENDIF
232	#endif
233	!
234	IF( jpnij < 1 ) THEN ! If jpnij is not specified in namelist then we calculate it
235	jpnij = jpni * jpnj ! this means there will be no land cutting out.
236	ENDIF
237
238	IF( jpni < 1 .OR. jpnj < 1 ) THEN
239	WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1
240	ELSE
241	WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1
242	WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1
243	WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1
244	ENDIF
245
246	WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1
247
248	CALL mpi_initialized ( mpi_was_called, code )
249	IF( code /= MPI_SUCCESS ) THEN
250	DO ji = 1, SIZE(ldtxt)
251	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
252	END DO
253	WRITE(*, cform_err)
254	WRITE(, ) 'lib_mpp: Error in routine mpi_initialized'
255	CALL mpi_abort( mpi_comm_world, code, ierr )
256	ENDIF
257
258	IF( mpi_was_called ) THEN
259	!
260	SELECT CASE ( cn_mpi_send )
261	CASE ( 'S' ) ! Standard mpi send (blocking)
262	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
263	CASE ( 'B' ) ! Buffer mpi send (blocking)
264	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
265	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
266	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
267	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
268	l_isend = .TRUE.
269	CASE DEFAULT
270	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
271	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
272	kstop = kstop + 1
273	END SELECT
274	!
275	ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN
276	WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1
277	WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1
278	kstop = kstop + 1
279	ELSE
280	SELECT CASE ( cn_mpi_send )
281	CASE ( 'S' ) ! Standard mpi send (blocking)
282	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
283	CALL mpi_init( ierr )
284	CASE ( 'B' ) ! Buffer mpi send (blocking)
285	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
286	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
287	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
288	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
289	l_isend = .TRUE.
290	CALL mpi_init( ierr )
291	CASE DEFAULT
292	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
293	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
294	kstop = kstop + 1
295	END SELECT
296	!
297	ENDIF
298
299	IF( PRESENT(localComm) ) THEN
300	IF( Agrif_Root() ) THEN
301	mpi_comm_opa = localComm
302	ENDIF
303	ELSE
304	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
305	IF( code /= MPI_SUCCESS ) THEN
306	DO ji = 1, SIZE(ldtxt)
307	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
308	END DO
309	WRITE(*, cform_err)
310	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
311	CALL mpi_abort( mpi_comm_world, code, ierr )
312	ENDIF
313	ENDIF
314
315	#if defined key_agrif
316	IF( Agrif_Root() ) THEN
317	CALL Agrif_MPI_Init(mpi_comm_opa)
318	ELSE
319	CALL Agrif_MPI_set_grid_comm(mpi_comm_opa)
320	ENDIF
321	#endif
322
323	CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
324	CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
325	mynode = mpprank
326
327	IF( mynode == 0 ) THEN
328	CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
329	WRITE(kumond, nammpp)
330	ENDIF
331	!
332	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
333	!
334	END FUNCTION mynode
335
336	!!----------------------------------------------------------------------
337	!! * routine mpp_lnk_(2,3,4)d *
338	!!
339	!! * Argument : dummy argument use in mpp_lnk_... routines
340	!! ptab : array or pointer of arrays on which the boundary condition is applied
341	!! cd_nat : nature of array grid-points
342	!! psgn : sign used across the north fold boundary
343	!! kfld : optional, number of pt3d arrays
344	!! cd_mpp : optional, fill the overlap area only
345	!! pval : optional, background value (used at closed boundaries)
346	!!----------------------------------------------------------------------
347	!
348	! !== 2D array and array of 2D pointer ==!
349	!
350	# define DIM_2d
351	# define ROUTINE_LNK mpp_lnk_2d
352	# include "mpp_lnk_generic.h90"
353	# undef ROUTINE_LNK
354	# define MULTI
355	# define ROUTINE_LNK mpp_lnk_2d_ptr
356	# include "mpp_lnk_generic.h90"
357	# undef ROUTINE_LNK
358	# undef MULTI
359	# undef DIM_2d
360	!
361	! !== 3D array and array of 3D pointer ==!
362	!
363	# define DIM_3d
364	# define ROUTINE_LNK mpp_lnk_3d
365	# include "mpp_lnk_generic.h90"
366	# undef ROUTINE_LNK
367	# define MULTI
368	# define ROUTINE_LNK mpp_lnk_3d_ptr
369	# include "mpp_lnk_generic.h90"
370	# undef ROUTINE_LNK
371	# undef MULTI
372	# undef DIM_3d
373	!
374	! !== 4D array and array of 4D pointer ==!
375	!
376	# define DIM_4d
377	# define ROUTINE_LNK mpp_lnk_4d
378	# include "mpp_lnk_generic.h90"
379	# undef ROUTINE_LNK
380	# define MULTI
381	# define ROUTINE_LNK mpp_lnk_4d_ptr
382	# include "mpp_lnk_generic.h90"
383	# undef ROUTINE_LNK
384	# undef MULTI
385	# undef DIM_4d
386
387	!!----------------------------------------------------------------------
388	!! * routine mpp_nfd_(2,3,4)d *
389	!!
390	!! * Argument : dummy argument use in mpp_nfd_... routines
391	!! ptab : array or pointer of arrays on which the boundary condition is applied
392	!! cd_nat : nature of array grid-points
393	!! psgn : sign used across the north fold boundary
394	!! kfld : optional, number of pt3d arrays
395	!! cd_mpp : optional, fill the overlap area only
396	!! pval : optional, background value (used at closed boundaries)
397	!!----------------------------------------------------------------------
398	!
399	! !== 2D array and array of 2D pointer ==!
400	!
401	# define DIM_2d
402	# define ROUTINE_NFD mpp_nfd_2d
403	# include "mpp_nfd_generic.h90"
404	# undef ROUTINE_NFD
405	# define MULTI
406	# define ROUTINE_NFD mpp_nfd_2d_ptr
407	# include "mpp_nfd_generic.h90"
408	# undef ROUTINE_NFD
409	# undef MULTI
410	# undef DIM_2d
411	!
412	! !== 3D array and array of 3D pointer ==!
413	!
414	# define DIM_3d
415	# define ROUTINE_NFD mpp_nfd_3d
416	# include "mpp_nfd_generic.h90"
417	# undef ROUTINE_NFD
418	# define MULTI
419	# define ROUTINE_NFD mpp_nfd_3d_ptr
420	# include "mpp_nfd_generic.h90"
421	# undef ROUTINE_NFD
422	# undef MULTI
423	# undef DIM_3d
424	!
425	! !== 4D array and array of 4D pointer ==!
426	!
427	# define DIM_4d
428	# define ROUTINE_NFD mpp_nfd_4d
429	# include "mpp_nfd_generic.h90"
430	# undef ROUTINE_NFD
431	# define MULTI
432	# define ROUTINE_NFD mpp_nfd_4d_ptr
433	# include "mpp_nfd_generic.h90"
434	# undef ROUTINE_NFD
435	# undef MULTI
436	# undef DIM_4d
437
438
439	!!----------------------------------------------------------------------
440	!! * routine mpp_lnk_bdy_(2,3,4)d *
441	!!
442	!! * Argument : dummy argument use in mpp_lnk_... routines
443	!! ptab : array or pointer of arrays on which the boundary condition is applied
444	!! cd_nat : nature of array grid-points
445	!! psgn : sign used across the north fold boundary
446	!! kb_bdy : BDY boundary set
447	!! kfld : optional, number of pt3d arrays
448	!!----------------------------------------------------------------------
449	!
450	! !== 2D array and array of 2D pointer ==!
451	!
452	# define DIM_2d
453	# define ROUTINE_BDY mpp_lnk_bdy_2d
454	# include "mpp_bdy_generic.h90"
455	# undef ROUTINE_BDY
456	# define MULTI
457	# define ROUTINE_BDY mpp_lnk_bdy_2d_ptr
458	# include "mpp_bdy_generic.h90"
459	# undef ROUTINE_BDY
460	# undef MULTI
461	# undef DIM_2d
462	!
463	! !== 3D array and array of 3D pointer ==!
464	!
465	# define DIM_3d
466	# define ROUTINE_BDY mpp_lnk_bdy_3d
467	# include "mpp_bdy_generic.h90"
468	# undef ROUTINE_BDY
469	# define MULTI
470	# define ROUTINE_BDY mpp_lnk_bdy_3d_ptr
471	# include "mpp_bdy_generic.h90"
472	# undef ROUTINE_BDY
473	# undef MULTI
474	# undef DIM_3d
475	!
476	! !== 4D array and array of 4D pointer ==!
477	!
478	!!# define DIM_4d
479	!!# define ROUTINE_BDY mpp_lnk_bdy_4d
480	!!# include "mpp_bdy_generic.h90"
481	!!# undef ROUTINE_BDY
482	!!# define MULTI
483	!!# define ROUTINE_BDY mpp_lnk_bdy_4d_ptr
484	!!# include "mpp_bdy_generic.h90"
485	!!# undef ROUTINE_BDY
486	!!# undef MULTI
487	!!# undef DIM_4d
488
489	!!----------------------------------------------------------------------
490	!!
491	!! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D
492
493
494	!! mpp_lnk_2d_e utilisé dans ICB
495
496
497	!! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!!
498
499
500	!!----------------------------------------------------------------------
501
502
503	SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
504	!!----------------------------------------------------------------------
505	!! * routine mpp_lnk_2d_e *
506	!!
507	!! ** Purpose : Message passing manadgement for 2d array (with halo)
508	!!
509	!! ** Method : Use mppsend and mpprecv function for passing mask
510	!! between processors following neighboring subdomains.
511	!! domain parameters
512	!! nlci : first dimension of the local subdomain
513	!! nlcj : second dimension of the local subdomain
514	!! jpri : number of rows for extra outer halo
515	!! jprj : number of columns for extra outer halo
516	!! nbondi : mark for "east-west local boundary"
517	!! nbondj : mark for "north-south local boundary"
518	!! noea : number for local neighboring processors
519	!! nowe : number for local neighboring processors
520	!! noso : number for local neighboring processors
521	!! nono : number for local neighboring processors
522	!!
523	!!----------------------------------------------------------------------
524	INTEGER , INTENT(in ) :: jpri
525	INTEGER , INTENT(in ) :: jprj
526	REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo
527	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
528	! ! = T , U , V , F , W and I points
529	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the
530	!! ! north boundary, = 1. otherwise
531	INTEGER :: jl ! dummy loop indices
532	INTEGER :: imigr, iihom, ijhom ! temporary integers
533	INTEGER :: ipreci, iprecj ! temporary integers
534	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
535	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
536	!!
537	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
538	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
539	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
540	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
541	!!----------------------------------------------------------------------
542
543	ipreci = jpreci + jpri ! take into account outer extra 2D overlap area
544	iprecj = jprecj + jprj
545
546
547	! 1. standard boundary treatment (CAUTION: the order matters Here !!!! )
548	! ------------------------------
549	! !== North-South boundaries
550	! !* cyclic
551	IF( nbondj == 2 .AND. jperio == 7 ) THEN
552	pt2d(:, 1-jprj: 1 ) = pt2d ( :, jpjm1-jprj:jpjm1 )
553	pt2d(:, jpj :jpj+jprj) = pt2d ( :, 2 :2+jprj)
554	ELSE !* closed
555	IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0._wp ! south except at F-point
556	pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0._wp ! north
557	ENDIF
558	! !== East-West boundaries
559	! !* Cyclic east-west
560	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
561	pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east
562	pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west
563	ELSE !* closed
564	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point
565	pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north
566	ENDIF
567	!
568	! north fold treatment
569	! --------------------
570	IF( npolj /= 0 ) THEN
571	!
572	SELECT CASE ( jpni )
573	!!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
574	!!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )
575	END SELECT
576	!
577	ENDIF
578
579	! 2. East and west directions exchange
580	! ------------------------------------
581	! we play with the neigbours AND the row number because of the periodicity
582	!
583	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
584	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
585	iihom = nlci-nreci-jpri
586	DO jl = 1, ipreci
587	r2dew(:,jl,1) = pt2d(jpreci+jl,:)
588	r2dwe(:,jl,1) = pt2d(iihom +jl,:)
589	END DO
590	END SELECT
591	!
592	! ! Migrations
593	imigr = ipreci * ( jpj + 2*jprj)
594	!
595	SELECT CASE ( nbondi )
596	CASE ( -1 )
597	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
598	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
599	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
600	CASE ( 0 )
601	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
602	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
603	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
604	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
605	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
606	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
607	CASE ( 1 )
608	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
609	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
610	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
611	END SELECT
612	!
613	! ! Write Dirichlet lateral conditions
614	iihom = nlci - jpreci
615	!
616	SELECT CASE ( nbondi )
617	CASE ( -1 )
618	DO jl = 1, ipreci
619	pt2d(iihom+jl,:) = r2dew(:,jl,2)
620	END DO
621	CASE ( 0 )
622	DO jl = 1, ipreci
623	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
624	pt2d( iihom+jl,:) = r2dew(:,jl,2)
625	END DO
626	CASE ( 1 )
627	DO jl = 1, ipreci
628	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
629	END DO
630	END SELECT
631
632	! 3. North and south directions
633	! -----------------------------
634	! always closed : we play only with the neigbours
635	!
636	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
637	ijhom = nlcj-nrecj-jprj
638	DO jl = 1, iprecj
639	r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
640	r2dns(:,jl,1) = pt2d(:,jprecj+jl)
641	END DO
642	ENDIF
643	!
644	! ! Migrations
645	imigr = iprecj * ( jpi + 2*jpri )
646	!
647	SELECT CASE ( nbondj )
648	CASE ( -1 )
649	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
650	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
651	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
652	CASE ( 0 )
653	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
654	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
655	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
656	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
657	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
658	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
659	CASE ( 1 )
660	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
661	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
662	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
663	END SELECT
664	!
665	! ! Write Dirichlet lateral conditions
666	ijhom = nlcj - jprecj
667	!
668	SELECT CASE ( nbondj )
669	CASE ( -1 )
670	DO jl = 1, iprecj
671	pt2d(:,ijhom+jl) = r2dns(:,jl,2)
672	END DO
673	CASE ( 0 )
674	DO jl = 1, iprecj
675	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
676	pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
677	END DO
678	CASE ( 1 )
679	DO jl = 1, iprecj
680	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
681	END DO
682	END SELECT
683	!
684	END SUBROUTINE mpp_lnk_2d_e
685
686
687	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
688	!!----------------------------------------------------------------------
689	!! * routine mppsend *
690	!!
691	!! ** Purpose : Send messag passing array
692	!!
693	!!----------------------------------------------------------------------
694	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
695	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
696	INTEGER , INTENT(in ) :: kdest ! receive process number
697	INTEGER , INTENT(in ) :: ktyp ! tag of the message
698	INTEGER , INTENT(in ) :: md_req ! argument for isend
699	!!
700	INTEGER :: iflag
701	!!----------------------------------------------------------------------
702	!
703	SELECT CASE ( cn_mpi_send )
704	CASE ( 'S' ) ! Standard mpi send (blocking)
705	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
706	CASE ( 'B' ) ! Buffer mpi send (blocking)
707	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
708	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
709	! be carefull, one more argument here : the mpi request identifier..
710	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
711	END SELECT
712	!
713	END SUBROUTINE mppsend
714
715
716	SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
717	!!----------------------------------------------------------------------
718	!! * routine mpprecv *
719	!!
720	!! ** Purpose : Receive messag passing array
721	!!
722	!!----------------------------------------------------------------------
723	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
724	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
725	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
726	INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
727	!!
728	INTEGER :: istatus(mpi_status_size)
729	INTEGER :: iflag
730	INTEGER :: use_source
731	!!----------------------------------------------------------------------
732	!
733	! If a specific process number has been passed to the receive call,
734	! use that one. Default is to use mpi_any_source
735	use_source = mpi_any_source
736	IF( PRESENT(ksource) ) use_source = ksource
737	!
738	CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag )
739	!
740	END SUBROUTINE mpprecv
741
742
743	SUBROUTINE mppgather( ptab, kp, pio )
744	!!----------------------------------------------------------------------
745	!! * routine mppgather *
746	!!
747	!! ** Purpose : Transfert between a local subdomain array and a work
748	!! array which is distributed following the vertical level.
749	!!
750	!!----------------------------------------------------------------------
751	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array
752	INTEGER , INTENT(in ) :: kp ! record length
753	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
754	!!
755	INTEGER :: itaille, ierror ! temporary integer
756	!!---------------------------------------------------------------------
757	!
758	itaille = jpi * jpj
759	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
760	& mpi_double_precision, kp , mpi_comm_opa, ierror )
761	!
762	END SUBROUTINE mppgather
763
764
765	SUBROUTINE mppscatter( pio, kp, ptab )
766	!!----------------------------------------------------------------------
767	!! * routine mppscatter *
768	!!
769	!! ** Purpose : Transfert between awork array which is distributed
770	!! following the vertical level and the local subdomain array.
771	!!
772	!!----------------------------------------------------------------------
773	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
774	INTEGER :: kp ! Tag (not used with MPI
775	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
776	!!
777	INTEGER :: itaille, ierror ! temporary integer
778	!!---------------------------------------------------------------------
779	!
780	itaille = jpi * jpj
781	!
782	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
783	& mpi_double_precision, kp , mpi_comm_opa, ierror )
784	!
785	END SUBROUTINE mppscatter
786
787	!!----------------------------------------------------------------------
788	!! * mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *
789	!!
790	!!----------------------------------------------------------------------
791	!!
792	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
793	!!----------------------------------------------------------------------
794	INTEGER , INTENT(in ) :: kdim ! size of array
795	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
796	INTEGER , INTENT(in ), OPTIONAL :: kcom !
797	INTEGER :: ierror, ilocalcomm ! temporary integer
798	INTEGER, DIMENSION(kdim) :: iwork
799	!!----------------------------------------------------------------------
800	ilocalcomm = mpi_comm_opa
801	IF( PRESENT(kcom) ) ilocalcomm = kcom
802	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror )
803	ktab(:) = iwork(:)
804	END SUBROUTINE mppmax_a_int
805	!!
806	SUBROUTINE mppmax_int( ktab, kcom )
807	!!----------------------------------------------------------------------
808	INTEGER, INTENT(inout) :: ktab ! ???
809	INTEGER, INTENT(in ), OPTIONAL :: kcom ! ???
810	INTEGER :: ierror, iwork, ilocalcomm ! temporary integer
811	!!----------------------------------------------------------------------
812	ilocalcomm = mpi_comm_opa
813	IF( PRESENT(kcom) ) ilocalcomm = kcom
814	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror )
815	ktab = iwork
816	END SUBROUTINE mppmax_int
817	!!
818	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
819	!!----------------------------------------------------------------------
820	REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab
821	INTEGER , INTENT(in ) :: kdim
822	INTEGER , OPTIONAL , INTENT(in ) :: kcom
823	INTEGER :: ierror, ilocalcomm
824	REAL(wp), DIMENSION(kdim) :: zwork
825	!!----------------------------------------------------------------------
826	ilocalcomm = mpi_comm_opa
827	IF( PRESENT(kcom) ) ilocalcomm = kcom
828	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror )
829	ptab(:) = zwork(:)
830	END SUBROUTINE mppmax_a_real
831	!!
832	SUBROUTINE mppmax_real( ptab, kcom )
833	!!----------------------------------------------------------------------
834	REAL(wp), INTENT(inout) :: ptab ! ???
835	INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???
836	INTEGER :: ierror, ilocalcomm
837	REAL(wp) :: zwork
838	!!----------------------------------------------------------------------
839	ilocalcomm = mpi_comm_opa
840	IF( PRESENT(kcom) ) ilocalcomm = kcom!
841	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror )
842	ptab = zwork
843	END SUBROUTINE mppmax_real
844
845
846	!!----------------------------------------------------------------------
847	!! * mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *
848	!!
849	!!----------------------------------------------------------------------
850	!!
851	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
852	!!----------------------------------------------------------------------
853	INTEGER , INTENT( in ) :: kdim ! size of array
854	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
855	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
856	!!
857	INTEGER :: ierror, ilocalcomm ! temporary integer
858	INTEGER, DIMENSION(kdim) :: iwork
859	!!----------------------------------------------------------------------
860	ilocalcomm = mpi_comm_opa
861	IF( PRESENT(kcom) ) ilocalcomm = kcom
862	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror )
863	ktab(:) = iwork(:)
864	END SUBROUTINE mppmin_a_int
865	!!
866	SUBROUTINE mppmin_int( ktab, kcom )
867	!!----------------------------------------------------------------------
868	INTEGER, INTENT(inout) :: ktab ! ???
869	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
870	!!
871	INTEGER :: ierror, iwork, ilocalcomm
872	!!----------------------------------------------------------------------
873	ilocalcomm = mpi_comm_opa
874	IF( PRESENT(kcom) ) ilocalcomm = kcom
875	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror )
876	ktab = iwork
877	END SUBROUTINE mppmin_int
878	!!
879	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
880	!!----------------------------------------------------------------------
881	INTEGER , INTENT(in ) :: kdim
882	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
883	INTEGER , INTENT(in ), OPTIONAL :: kcom
884	INTEGER :: ierror, ilocalcomm
885	REAL(wp), DIMENSION(kdim) :: zwork
886	!!-----------------------------------------------------------------------
887	ilocalcomm = mpi_comm_opa
888	IF( PRESENT(kcom) ) ilocalcomm = kcom
889	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror )
890	ptab(:) = zwork(:)
891	END SUBROUTINE mppmin_a_real
892	!!
893	SUBROUTINE mppmin_real( ptab, kcom )
894	!!-----------------------------------------------------------------------
895	REAL(wp), INTENT(inout) :: ptab !
896	INTEGER , INTENT(in ), OPTIONAL :: kcom
897	INTEGER :: ierror, ilocalcomm
898	REAL(wp) :: zwork
899	!!-----------------------------------------------------------------------
900	ilocalcomm = mpi_comm_opa
901	IF( PRESENT(kcom) ) ilocalcomm = kcom
902	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror )
903	ptab = zwork
904	END SUBROUTINE mppmin_real
905
906
907	!!----------------------------------------------------------------------
908	!! * mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *
909	!!
910	!! Global sum of 1D array or a variable (integer, real or complex)
911	!!----------------------------------------------------------------------
912	!!
913	SUBROUTINE mppsum_a_int( ktab, kdim )
914	!!----------------------------------------------------------------------
915	INTEGER, INTENT(in ) :: kdim ! ???
916	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
917	INTEGER :: ierror
918	INTEGER, DIMENSION (kdim) :: iwork
919	!!----------------------------------------------------------------------
920	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
921	ktab(:) = iwork(:)
922	END SUBROUTINE mppsum_a_int
923	!!
924	SUBROUTINE mppsum_int( ktab )
925	!!----------------------------------------------------------------------
926	INTEGER, INTENT(inout) :: ktab
927	INTEGER :: ierror, iwork
928	!!----------------------------------------------------------------------
929	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
930	ktab = iwork
931	END SUBROUTINE mppsum_int
932	!!
933	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
934	!!-----------------------------------------------------------------------
935	INTEGER , INTENT(in ) :: kdim ! size of ptab
936	REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab ! input array
937	INTEGER , OPTIONAL , INTENT(in ) :: kcom ! specific communicator
938	INTEGER :: ierror, ilocalcomm ! local integer
939	REAL(wp) :: zwork(kdim) ! local workspace
940	!!-----------------------------------------------------------------------
941	ilocalcomm = mpi_comm_opa
942	IF( PRESENT(kcom) ) ilocalcomm = kcom
943	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror )
944	ptab(:) = zwork(:)
945	END SUBROUTINE mppsum_a_real
946	!!
947	SUBROUTINE mppsum_real( ptab, kcom )
948	!!-----------------------------------------------------------------------
949	REAL(wp) , INTENT(inout) :: ptab ! input scalar
950	INTEGER , OPTIONAL, INTENT(in ) :: kcom
951	INTEGER :: ierror, ilocalcomm
952	REAL(wp) :: zwork
953	!!-----------------------------------------------------------------------
954	ilocalcomm = mpi_comm_opa
955	IF( PRESENT(kcom) ) ilocalcomm = kcom
956	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror )
957	ptab = zwork
958	END SUBROUTINE mppsum_real
959	!!
960	SUBROUTINE mppsum_realdd( ytab, kcom )
961	!!-----------------------------------------------------------------------
962	COMPLEX(wp) , INTENT(inout) :: ytab ! input scalar
963	INTEGER , OPTIONAL, INTENT(in ) :: kcom
964	INTEGER :: ierror, ilocalcomm
965	COMPLEX(wp) :: zwork
966	!!-----------------------------------------------------------------------
967	ilocalcomm = mpi_comm_opa
968	IF( PRESENT(kcom) ) ilocalcomm = kcom
969	CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror )
970	ytab = zwork
971	END SUBROUTINE mppsum_realdd
972	!!
973	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
974	!!----------------------------------------------------------------------
975	INTEGER , INTENT(in ) :: kdim ! size of ytab
976	COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array
977	INTEGER , OPTIONAL , INTENT(in ) :: kcom
978	INTEGER:: ierror, ilocalcomm ! local integer
979	COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace
980	!!-----------------------------------------------------------------------
981	ilocalcomm = mpi_comm_opa
982	IF( PRESENT(kcom) ) ilocalcomm = kcom
983	CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror )
984	ytab(:) = zwork(:)
985	END SUBROUTINE mppsum_a_realdd
986
987
988	SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom )
989	!!----------------------------------------------------------------------
990	!! * routine mppmax_real *
991	!!
992	!! ** Purpose : Maximum across processor of each element of a 1D arrays
993	!!
994	!!----------------------------------------------------------------------
995	REAL(wp), DIMENSION(kdim), INTENT(inout) :: pt1d ! 1D arrays
996	INTEGER , INTENT(in ) :: kdim
997	INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator
998	!!
999	INTEGER :: ierror, ilocalcomm
1000	REAL(wp), DIMENSION(kdim) :: zwork
1001	!!----------------------------------------------------------------------
1002	ilocalcomm = mpi_comm_opa
1003	IF( PRESENT(kcom) ) ilocalcomm = kcom
1004	!
1005	CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror )
1006	pt1d(:) = zwork(:)
1007	!
1008	END SUBROUTINE mppmax_real_multiple
1009
1010
1011	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1012	!!------------------------------------------------------------------------
1013	!! * routine mpp_minloc *
1014	!!
1015	!! ** Purpose : Compute the global minimum of an array ptab
1016	!! and also give its global position
1017	!!
1018	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1019	!!
1020	!!--------------------------------------------------------------------------
1021	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
1022	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
1023	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
1024	INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame
1025	!
1026	INTEGER :: ierror
1027	INTEGER , DIMENSION(2) :: ilocs
1028	REAL(wp) :: zmin ! local minimum
1029	REAL(wp), DIMENSION(2,1) :: zain, zaout
1030	!!-----------------------------------------------------------------------
1031	!
1032	zmin = MINVAL( ptab(:,:) , mask= pmask == 1._wp )
1033	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp )
1034	!
1035	ki = ilocs(1) + nimpp - 1
1036	kj = ilocs(2) + njmpp - 1
1037	!
1038	zain(1,:)=zmin
1039	zain(2,:)=ki+10000.*kj
1040	!
1041	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1042	!
1043	pmin = zaout(1,1)
1044	kj = INT(zaout(2,1)/10000.)
1045	ki = INT(zaout(2,1) - 10000.*kj )
1046	!
1047	END SUBROUTINE mpp_minloc2d
1048
1049
1050	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1051	!!------------------------------------------------------------------------
1052	!! * routine mpp_minloc *
1053	!!
1054	!! ** Purpose : Compute the global minimum of an array ptab
1055	!! and also give its global position
1056	!!
1057	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1058	!!
1059	!!--------------------------------------------------------------------------
1060	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! Local 2D array
1061	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! Local mask
1062	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
1063	INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame
1064	!
1065	INTEGER :: ierror
1066	REAL(wp) :: zmin ! local minimum
1067	INTEGER , DIMENSION(3) :: ilocs
1068	REAL(wp), DIMENSION(2,1) :: zain, zaout
1069	!!-----------------------------------------------------------------------
1070	!
1071	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp )
1072	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp )
1073	!
1074	ki = ilocs(1) + nimpp - 1
1075	kj = ilocs(2) + njmpp - 1
1076	kk = ilocs(3)
1077	!
1078	zain(1,:) = zmin
1079	zain(2,:) = ki + 10000.kj + 100000000.kk
1080	!
1081	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1082	!
1083	pmin = zaout(1,1)
1084	kk = INT( zaout(2,1) / 100000000. )
1085	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
1086	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1087	!
1088	END SUBROUTINE mpp_minloc3d
1089
1090
1091	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1092	!!------------------------------------------------------------------------
1093	!! * routine mpp_maxloc *
1094	!!
1095	!! ** Purpose : Compute the global maximum of an array ptab
1096	!! and also give its global position
1097	!!
1098	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1099	!!
1100	!!--------------------------------------------------------------------------
1101	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
1102	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
1103	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
1104	INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame
1105	!!
1106	INTEGER :: ierror
1107	INTEGER, DIMENSION (2) :: ilocs
1108	REAL(wp) :: zmax ! local maximum
1109	REAL(wp), DIMENSION(2,1) :: zain, zaout
1110	!!-----------------------------------------------------------------------
1111	!
1112	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1._wp )
1113	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp )
1114	!
1115	ki = ilocs(1) + nimpp - 1
1116	kj = ilocs(2) + njmpp - 1
1117	!
1118	zain(1,:) = zmax
1119	zain(2,:) = ki + 10000. * kj
1120	!
1121	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1122	!
1123	pmax = zaout(1,1)
1124	kj = INT( zaout(2,1) / 10000. )
1125	ki = INT( zaout(2,1) - 10000.* kj )
1126	!
1127	END SUBROUTINE mpp_maxloc2d
1128
1129
1130	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
1131	!!------------------------------------------------------------------------
1132	!! * routine mpp_maxloc *
1133	!!
1134	!! ** Purpose : Compute the global maximum of an array ptab
1135	!! and also give its global position
1136	!!
1137	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1138	!!
1139	!!--------------------------------------------------------------------------
1140	REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: ptab ! Local 2D array
1141	REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pmask ! Local mask
1142	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
1143	INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame
1144	!
1145	INTEGER :: ierror ! local integer
1146	REAL(wp) :: zmax ! local maximum
1147	REAL(wp), DIMENSION(2,1) :: zain, zaout
1148	INTEGER , DIMENSION(3) :: ilocs
1149	!!-----------------------------------------------------------------------
1150	!
1151	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp )
1152	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp )
1153	!
1154	ki = ilocs(1) + nimpp - 1
1155	kj = ilocs(2) + njmpp - 1
1156	kk = ilocs(3)
1157	!
1158	zain(1,:) = zmax
1159	zain(2,:) = ki + 10000.kj + 100000000.kk
1160	!
1161	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1162	!
1163	pmax = zaout(1,1)
1164	kk = INT( zaout(2,1) / 100000000. )
1165	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
1166	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1167	!
1168	END SUBROUTINE mpp_maxloc3d
1169
1170
1171	SUBROUTINE mppsync()
1172	!!----------------------------------------------------------------------
1173	!! * routine mppsync *
1174	!!
1175	!! ** Purpose : Massively parallel processors, synchroneous
1176	!!
1177	!!-----------------------------------------------------------------------
1178	INTEGER :: ierror
1179	!!-----------------------------------------------------------------------
1180	!
1181	CALL mpi_barrier( mpi_comm_opa, ierror )
1182	!
1183	END SUBROUTINE mppsync
1184
1185
1186	SUBROUTINE mppstop
1187
1188	USE mod_oasis ! coupling routines
1189
1190	!!----------------------------------------------------------------------
1191	!! * routine mppstop *
1192	!!
1193	!! ** purpose : Stop massively parallel processors method
1194	!!
1195	!!----------------------------------------------------------------------
1196	INTEGER :: info
1197	!!----------------------------------------------------------------------
1198	!
1199
1200	#if defined key_oasis3
1201	! If we're trying to shut down cleanly then we need to consider the fact
1202	! that this could be part of an MPMD configuration - we don't want to
1203	! leave other components deadlocked.
1204
1205	CALL oasis_abort(nproc,"mppstop","NEMO initiated abort")
1206
1207
1208	#else
1209
1210	CALL mppsync
1211	CALL mpi_finalize( info )
1212	#endif
1213
1214	!
1215	END SUBROUTINE mppstop
1216
1217
1218	SUBROUTINE mpp_comm_free( kcom )
1219	!!----------------------------------------------------------------------
1220	INTEGER, INTENT(in) :: kcom
1221	!!
1222	INTEGER :: ierr
1223	!!----------------------------------------------------------------------
1224	!
1225	CALL MPI_COMM_FREE(kcom, ierr)
1226	!
1227	END SUBROUTINE mpp_comm_free
1228
1229
1230	SUBROUTINE mpp_ini_ice( pindic, kumout )
1231	!!----------------------------------------------------------------------
1232	!! * routine mpp_ini_ice *
1233	!!
1234	!! ** Purpose : Initialize special communicator for ice areas
1235	!! condition together with global variables needed in the ddmpp folding
1236	!!
1237	!! ** Method : - Look for ice processors in ice routines
1238	!! - Put their number in nrank_ice
1239	!! - Create groups for the world processors and the ice processors
1240	!! - Create a communicator for ice processors
1241	!!
1242	!! ** output
1243	!! njmppmax = njmpp for northern procs
1244	!! ndim_rank_ice = number of processors with ice
1245	!! nrank_ice (ndim_rank_ice) = ice processors
1246	!! ngrp_iworld = group ID for the world processors
1247	!! ngrp_ice = group ID for the ice processors
1248	!! ncomm_ice = communicator for the ice procs.
1249	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
1250	!!
1251	!!----------------------------------------------------------------------
1252	INTEGER, INTENT(in) :: pindic
1253	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
1254	!!
1255	INTEGER :: jjproc
1256	INTEGER :: ii, ierr
1257	INTEGER, ALLOCATABLE, DIMENSION(:) :: kice
1258	INTEGER, ALLOCATABLE, DIMENSION(:) :: zwork
1259	!!----------------------------------------------------------------------
1260	!
1261	! Since this is just an init routine and these arrays are of length jpnij
1262	! then don't use wrk_nemo module - just allocate and deallocate.
1263	ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
1264	IF( ierr /= 0 ) THEN
1265	WRITE(kumout, cform_err)
1266	WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
1267	CALL mppstop
1268	ENDIF
1269
1270	! Look for how many procs with sea-ice
1271	!
1272	kice = 0
1273	DO jjproc = 1, jpnij
1274	IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1
1275	END DO
1276	!
1277	zwork = 0
1278	CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
1279	ndim_rank_ice = SUM( zwork )
1280
1281	! Allocate the right size to nrank_north
1282	IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice )
1283	ALLOCATE( nrank_ice(ndim_rank_ice) )
1284	!
1285	ii = 0
1286	nrank_ice = 0
1287	DO jjproc = 1, jpnij
1288	IF( zwork(jjproc) == 1) THEN
1289	ii = ii + 1
1290	nrank_ice(ii) = jjproc -1
1291	ENDIF
1292	END DO
1293
1294	! Create the world group
1295	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
1296
1297	! Create the ice group from the world group
1298	CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
1299
1300	! Create the ice communicator , ie the pool of procs with sea-ice
1301	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
1302
1303	! Find proc number in the world of proc 0 in the north
1304	! The following line seems to be useless, we just comment & keep it as reminder
1305	! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
1306	!
1307	CALL MPI_GROUP_FREE(ngrp_ice, ierr)
1308	CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
1309
1310	DEALLOCATE(kice, zwork)
1311	!
1312	END SUBROUTINE mpp_ini_ice
1313
1314
1315	SUBROUTINE mpp_ini_znl( kumout )
1316	!!----------------------------------------------------------------------
1317	!! * routine mpp_ini_znl *
1318	!!
1319	!! ** Purpose : Initialize special communicator for computing zonal sum
1320	!!
1321	!! ** Method : - Look for processors in the same row
1322	!! - Put their number in nrank_znl
1323	!! - Create group for the znl processors
1324	!! - Create a communicator for znl processors
1325	!! - Determine if processor should write znl files
1326	!!
1327	!! ** output
1328	!! ndim_rank_znl = number of processors on the same row
1329	!! ngrp_znl = group ID for the znl processors
1330	!! ncomm_znl = communicator for the ice procs.
1331	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
1332	!!
1333	!!----------------------------------------------------------------------
1334	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
1335	!
1336	INTEGER :: jproc ! dummy loop integer
1337	INTEGER :: ierr, ii ! local integer
1338	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
1339	!!----------------------------------------------------------------------
1340	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
1341	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
1342	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa : ', mpi_comm_opa
1343	!
1344	ALLOCATE( kwork(jpnij), STAT=ierr )
1345	IF( ierr /= 0 ) THEN
1346	WRITE(kumout, cform_err)
1347	WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
1348	CALL mppstop
1349	ENDIF
1350
1351	IF( jpnj == 1 ) THEN
1352	ngrp_znl = ngrp_world
1353	ncomm_znl = mpi_comm_opa
1354	ELSE
1355	!
1356	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
1357	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
1358	!-$$ CALL flush(numout)
1359	!
1360	! Count number of processors on the same row
1361	ndim_rank_znl = 0
1362	DO jproc=1,jpnij
1363	IF ( kwork(jproc) == njmpp ) THEN
1364	ndim_rank_znl = ndim_rank_znl + 1
1365	ENDIF
1366	END DO
1367	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
1368	!-$$ CALL flush(numout)
1369	! Allocate the right size to nrank_znl
1370	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
1371	ALLOCATE(nrank_znl(ndim_rank_znl))
1372	ii = 0
1373	nrank_znl (:) = 0
1374	DO jproc=1,jpnij
1375	IF ( kwork(jproc) == njmpp) THEN
1376	ii = ii + 1
1377	nrank_znl(ii) = jproc -1
1378	ENDIF
1379	END DO
1380	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
1381	!-$$ CALL flush(numout)
1382
1383	! Create the opa group
1384	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
1385	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
1386	!-$$ CALL flush(numout)
1387
1388	! Create the znl group from the opa group
1389	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
1390	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
1391	!-$$ CALL flush(numout)
1392
1393	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
1394	CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
1395	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
1396	!-$$ CALL flush(numout)
1397	!
1398	END IF
1399
1400	! Determines if processor if the first (starting from i=1) on the row
1401	IF ( jpni == 1 ) THEN
1402	l_znl_root = .TRUE.
1403	ELSE
1404	l_znl_root = .FALSE.
1405	kwork (1) = nimpp
1406	CALL mpp_min ( kwork(1), kcom = ncomm_znl)
1407	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
1408	END IF
1409
1410	DEALLOCATE(kwork)
1411
1412	END SUBROUTINE mpp_ini_znl
1413
1414
1415	SUBROUTINE mpp_ini_north
1416	!!----------------------------------------------------------------------
1417	!! * routine mpp_ini_north *
1418	!!
1419	!! ** Purpose : Initialize special communicator for north folding
1420	!! condition together with global variables needed in the mpp folding
1421	!!
1422	!! ** Method : - Look for northern processors
1423	!! - Put their number in nrank_north
1424	!! - Create groups for the world processors and the north processors
1425	!! - Create a communicator for northern processors
1426	!!
1427	!! ** output
1428	!! njmppmax = njmpp for northern procs
1429	!! ndim_rank_north = number of processors in the northern line
1430	!! nrank_north (ndim_rank_north) = number of the northern procs.
1431	!! ngrp_world = group ID for the world processors
1432	!! ngrp_north = group ID for the northern processors
1433	!! ncomm_north = communicator for the northern procs.
1434	!! north_root = number (in the world) of proc 0 in the northern comm.
1435	!!
1436	!!----------------------------------------------------------------------
1437	INTEGER :: ierr
1438	INTEGER :: jjproc
1439	INTEGER :: ii, ji
1440	!!----------------------------------------------------------------------
1441	!
1442	njmppmax = MAXVAL( njmppt )
1443	!
1444	! Look for how many procs on the northern boundary
1445	ndim_rank_north = 0
1446	DO jjproc = 1, jpnij
1447	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
1448	END DO
1449	!
1450	! Allocate the right size to nrank_north
1451	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
1452	ALLOCATE( nrank_north(ndim_rank_north) )
1453
1454	! Fill the nrank_north array with proc. number of northern procs.
1455	! Note : the rank start at 0 in MPI
1456	ii = 0
1457	DO ji = 1, jpnij
1458	IF ( njmppt(ji) == njmppmax ) THEN
1459	ii=ii+1
1460	nrank_north(ii)=ji-1
1461	END IF
1462	END DO
1463	!
1464	! create the world group
1465	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
1466	!
1467	! Create the North group from the world group
1468	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
1469	!
1470	! Create the North communicator , ie the pool of procs in the north group
1471	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
1472	!
1473	END SUBROUTINE mpp_ini_north
1474
1475
1476	SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
1477	!!---------------------------------------------------------------------
1478	!! * routine mpp_lbc_north_2d *
1479	!!
1480	!! ** Purpose : Ensure proper north fold horizontal bondary condition
1481	!! in mpp configuration in case of jpn1 > 1 and for 2d
1482	!! array with outer extra halo
1483	!!
1484	!! ** Method : North fold condition and mpp with more than one proc
1485	!! in i-direction require a specific treatment. We gather
1486	!! the 4+2*jpr2dj northern lines of the global domain on 1
1487	!! processor and apply lbc north-fold on this sub array.
1488	!! Then we scatter the north fold array back to the processors.
1489	!!
1490	!!----------------------------------------------------------------------
1491	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
1492	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
1493	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold
1494	!
1495	INTEGER :: ji, jj, jr
1496	INTEGER :: ierr, itaille, ildi, ilei, iilb
1497	INTEGER :: ijpj, ij, iproc
1498	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
1499	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
1500	!!----------------------------------------------------------------------
1501	!
1502	ALLOCATE( ztab_e(jpiglo,4+2jpr2dj), znorthloc_e(jpi,4+2jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
1503	!
1504	ijpj=4
1505	ztab_e(:,:) = 0._wp
1506
1507	ij = 0
1508	! put in znorthloc_e the last 4 jlines of pt2d
1509	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
1510	ij = ij + 1
1511	DO ji = 1, jpi
1512	znorthloc_e(ji,ij) = pt2d(ji,jj)
1513	END DO
1514	END DO
1515	!
1516	itaille = jpi * ( ijpj + 2 * jpr2dj )
1517	CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
1518	& znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
1519	!
1520	DO jr = 1, ndim_rank_north ! recover the global north array
1521	iproc = nrank_north(jr) + 1
1522	ildi = nldit (iproc)
1523	ilei = nleit (iproc)
1524	iilb = nimppt(iproc)
1525	DO jj = 1, ijpj+2*jpr2dj
1526	DO ji = ildi, ilei
1527	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
1528	END DO
1529	END DO
1530	END DO
1531
1532	! 2. North-Fold boundary conditions
1533	! ----------------------------------
1534	!!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
1535
1536	ij = jpr2dj
1537	!! Scatter back to pt2d
1538	DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
1539	ij = ij +1
1540	DO ji= 1, nlci
1541	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
1542	END DO
1543	END DO
1544	!
1545	DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
1546	!
1547	END SUBROUTINE mpp_lbc_north_e
1548
1549
1550	SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
1551	!!---------------------------------------------------------------------
1552	!! * routine mpp_init.opa *
1553	!!
1554	!! ** Purpose :: export and attach a MPI buffer for bsend
1555	!!
1556	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
1557	!! but classical mpi_init
1558	!!
1559	!! History :: 01/11 :: IDRIS initial version for IBM only
1560	!! 08/04 :: R. Benshila, generalisation
1561	!!---------------------------------------------------------------------
1562	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
1563	INTEGER , INTENT(inout) :: ksft
1564	INTEGER , INTENT( out) :: code
1565	INTEGER :: ierr, ji
1566	LOGICAL :: mpi_was_called
1567	!!---------------------------------------------------------------------
1568	!
1569	CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization
1570	IF ( code /= MPI_SUCCESS ) THEN
1571	DO ji = 1, SIZE(ldtxt)
1572	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
1573	END DO
1574	WRITE(*, cform_err)
1575	WRITE(, ) ' lib_mpp: Error in routine mpi_initialized'
1576	CALL mpi_abort( mpi_comm_world, code, ierr )
1577	ENDIF
1578	!
1579	IF( .NOT. mpi_was_called ) THEN
1580	CALL mpi_init( code )
1581	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
1582	IF ( code /= MPI_SUCCESS ) THEN
1583	DO ji = 1, SIZE(ldtxt)
1584	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
1585	END DO
1586	WRITE(*, cform_err)
1587	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
1588	CALL mpi_abort( mpi_comm_world, code, ierr )
1589	ENDIF
1590	ENDIF
1591	!
1592	IF( nn_buffer > 0 ) THEN
1593	WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1
1594	! Buffer allocation and attachment
1595	ALLOCATE( tampon(nn_buffer), stat = ierr )
1596	IF( ierr /= 0 ) THEN
1597	DO ji = 1, SIZE(ldtxt)
1598	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
1599	END DO
1600	WRITE(*, cform_err)
1601	WRITE(, ) ' lib_mpp: Error in ALLOCATE', ierr
1602	CALL mpi_abort( mpi_comm_world, code, ierr )
1603	END IF
1604	CALL mpi_buffer_attach( tampon, nn_buffer, code )
1605	ENDIF
1606	!
1607	END SUBROUTINE mpi_init_opa
1608
1609
1610	SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
1611	!!---------------------------------------------------------------------
1612	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
1613	!!
1614	!! Modification of original codes written by David H. Bailey
1615	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
1616	!!---------------------------------------------------------------------
1617	INTEGER , INTENT(in) :: ilen, itype
1618	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
1619	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
1620	!
1621	REAL(wp) :: zerr, zt1, zt2 ! local work variables
1622	INTEGER :: ji, ztmp ! local scalar
1623	!!---------------------------------------------------------------------
1624	!
1625	ztmp = itype ! avoid compilation warning
1626	!
1627	DO ji=1,ilen
1628	! Compute ydda + yddb using Knuth's trick.
1629	zt1 = real(ydda(ji)) + real(yddb(ji))
1630	zerr = zt1 - real(ydda(ji))
1631	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
1632	+ aimag(ydda(ji)) + aimag(yddb(ji))
1633
1634	! The result is zt1 + zt2, after normalization.
1635	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
1636	END DO
1637	!
1638	END SUBROUTINE DDPDD_MPI
1639
1640
1641	SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
1642	!!---------------------------------------------------------------------
1643	!! * routine mpp_lbc_north_icb *
1644	!!
1645	!! ** Purpose : Ensure proper north fold horizontal bondary condition
1646	!! in mpp configuration in case of jpn1 > 1 and for 2d
1647	!! array with outer extra halo
1648	!!
1649	!! ** Method : North fold condition and mpp with more than one proc
1650	!! in i-direction require a specific treatment. We gather
1651	!! the 4+2*jpr2dj northern lines of the global domain on 1
1652	!! processor and apply lbc north-fold on this sub array.
1653	!! Then we scatter the north fold array back to the processors.
1654	!! This version accounts for an extra halo with icebergs.
1655	!!
1656	!!----------------------------------------------------------------------
1657	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo
1658	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
1659	! ! = T , U , V , F or W -points
1660	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
1661	!! ! north fold, = 1. otherwise
1662	INTEGER, OPTIONAL , INTENT(in ) :: pr2dj
1663	!
1664	INTEGER :: ji, jj, jr
1665	INTEGER :: ierr, itaille, ildi, ilei, iilb
1666	INTEGER :: ijpj, ij, iproc, ipr2dj
1667	!
1668	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
1669	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
1670	!!----------------------------------------------------------------------
1671	!
1672	ijpj=4
1673	IF( PRESENT(pr2dj) ) THEN ! use of additional halos
1674	ipr2dj = pr2dj
1675	ELSE
1676	ipr2dj = 0
1677	ENDIF
1678	ALLOCATE( ztab_e(jpiglo,4+2ipr2dj), znorthloc_e(jpi,4+2ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
1679	!
1680	ztab_e(:,:) = 0._wp
1681	!
1682	ij = 0
1683	! put in znorthloc_e the last 4 jlines of pt2d
1684	DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
1685	ij = ij + 1
1686	DO ji = 1, jpi
1687	znorthloc_e(ji,ij)=pt2d(ji,jj)
1688	END DO
1689	END DO
1690	!
1691	itaille = jpi * ( ijpj + 2 * ipr2dj )
1692	CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
1693	& znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
1694	!
1695	DO jr = 1, ndim_rank_north ! recover the global north array
1696	iproc = nrank_north(jr) + 1
1697	ildi = nldit (iproc)
1698	ilei = nleit (iproc)
1699	iilb = nimppt(iproc)
1700	DO jj = 1, ijpj+2*ipr2dj
1701	DO ji = ildi, ilei
1702	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
1703	END DO
1704	END DO
1705	END DO
1706
1707	! 2. North-Fold boundary conditions
1708	! ----------------------------------
1709	!!gm ERROR CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
1710
1711	ij = ipr2dj
1712	!! Scatter back to pt2d
1713	DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
1714	ij = ij +1
1715	DO ji= 1, nlci
1716	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
1717	END DO
1718	END DO
1719	!
1720	DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
1721	!
1722	END SUBROUTINE mpp_lbc_north_icb
1723
1724
1725	SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
1726	!!----------------------------------------------------------------------
1727	!! * routine mpp_lnk_2d_icb *
1728	!!
1729	!! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs)
1730	!!
1731	!! ** Method : Use mppsend and mpprecv function for passing mask
1732	!! between processors following neighboring subdomains.
1733	!! domain parameters
1734	!! nlci : first dimension of the local subdomain
1735	!! nlcj : second dimension of the local subdomain
1736	!! jpri : number of rows for extra outer halo
1737	!! jprj : number of columns for extra outer halo
1738	!! nbondi : mark for "east-west local boundary"
1739	!! nbondj : mark for "north-south local boundary"
1740	!! noea : number for local neighboring processors
1741	!! nowe : number for local neighboring processors
1742	!! noso : number for local neighboring processors
1743	!! nono : number for local neighboring processors
1744	!!----------------------------------------------------------------------
1745	REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo
1746	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
1747	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold
1748	INTEGER , INTENT(in ) :: jpri
1749	INTEGER , INTENT(in ) :: jprj
1750	!
1751	INTEGER :: jl ! dummy loop indices
1752	INTEGER :: imigr, iihom, ijhom ! local integers
1753	INTEGER :: ipreci, iprecj ! - -
1754	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1755	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
1756	!!
1757	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns, r2dsn
1758	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe, r2dew
1759	!!----------------------------------------------------------------------
1760
1761	ipreci = jpreci + jpri ! take into account outer extra 2D overlap area
1762	iprecj = jprecj + jprj
1763
1764
1765	! 1. standard boundary treatment
1766	! ------------------------------
1767	! Order matters Here !!!!
1768	!
1769	! ! East-West boundaries
1770	! !* Cyclic east-west
1771	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1772	pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east
1773	pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west
1774	!
1775	ELSE !* closed
1776	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0._wp ! south except at F-point
1777	pt2d(nlci-jpreci+1:jpi+jpri,:) = 0._wp ! north
1778	ENDIF
1779	!
1780
1781	! north fold treatment
1782	! -----------------------
1783	IF( npolj /= 0 ) THEN
1784	!
1785	SELECT CASE ( jpni )
1786	!!gm ERROR CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
1787	!!gm ERROR CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj )
1788	END SELECT
1789	!
1790	ENDIF
1791
1792	! 2. East and west directions exchange
1793	! ------------------------------------
1794	! we play with the neigbours AND the row number because of the periodicity
1795	!
1796	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
1797	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
1798	iihom = nlci-nreci-jpri
1799	DO jl = 1, ipreci
1800	r2dew(:,jl,1) = pt2d(jpreci+jl,:)
1801	r2dwe(:,jl,1) = pt2d(iihom +jl,:)
1802	END DO
1803	END SELECT
1804	!
1805	! ! Migrations
1806	imigr = ipreci * ( jpj + 2*jprj)
1807	!
1808	SELECT CASE ( nbondi )
1809	CASE ( -1 )
1810	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
1811	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
1812	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1813	CASE ( 0 )
1814	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
1815	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
1816	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
1817	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
1818	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1819	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1820	CASE ( 1 )
1821	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
1822	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
1823	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1824	END SELECT
1825	!
1826	! ! Write Dirichlet lateral conditions
1827	iihom = nlci - jpreci
1828	!
1829	SELECT CASE ( nbondi )
1830	CASE ( -1 )
1831	DO jl = 1, ipreci
1832	pt2d(iihom+jl,:) = r2dew(:,jl,2)
1833	END DO
1834	CASE ( 0 )
1835	DO jl = 1, ipreci
1836	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
1837	pt2d( iihom+jl,:) = r2dew(:,jl,2)
1838	END DO
1839	CASE ( 1 )
1840	DO jl = 1, ipreci
1841	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
1842	END DO
1843	END SELECT
1844
1845
1846	! 3. North and south directions
1847	! -----------------------------
1848	! always closed : we play only with the neigbours
1849	!
1850	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
1851	ijhom = nlcj-nrecj-jprj
1852	DO jl = 1, iprecj
1853	r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
1854	r2dns(:,jl,1) = pt2d(:,jprecj+jl)
1855	END DO
1856	ENDIF
1857	!
1858	! ! Migrations
1859	imigr = iprecj * ( jpi + 2*jpri )
1860	!
1861	SELECT CASE ( nbondj )
1862	CASE ( -1 )
1863	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
1864	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
1865	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1866	CASE ( 0 )
1867	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
1868	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
1869	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
1870	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
1871	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1872	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1873	CASE ( 1 )
1874	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
1875	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
1876	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1877	END SELECT
1878	!
1879	! ! Write Dirichlet lateral conditions
1880	ijhom = nlcj - jprecj
1881	!
1882	SELECT CASE ( nbondj )
1883	CASE ( -1 )
1884	DO jl = 1, iprecj
1885	pt2d(:,ijhom+jl) = r2dns(:,jl,2)
1886	END DO
1887	CASE ( 0 )
1888	DO jl = 1, iprecj
1889	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
1890	pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
1891	END DO
1892	CASE ( 1 )
1893	DO jl = 1, iprecj
1894	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
1895	END DO
1896	END SELECT
1897	!
1898	END SUBROUTINE mpp_lnk_2d_icb
1899
1900	#else
1901	!!----------------------------------------------------------------------
1902	!! Default case: Dummy module share memory computing
1903	!!----------------------------------------------------------------------
1904	USE in_out_manager
1905
1906	INTERFACE mpp_sum
1907	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
1908	END INTERFACE
1909	INTERFACE mpp_max
1910	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
1911	END INTERFACE
1912	INTERFACE mpp_min
1913	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
1914	END INTERFACE
1915	INTERFACE mpp_minloc
1916	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
1917	END INTERFACE
1918	INTERFACE mpp_maxloc
1919	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
1920	END INTERFACE
1921	INTERFACE mpp_max_multiple
1922	MODULE PROCEDURE mppmax_real_multiple
1923	END INTERFACE
1924
1925	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
1926	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
1927	INTEGER :: ncomm_ice
1928	INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator
1929	!!----------------------------------------------------------------------
1930	CONTAINS
1931
1932	INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function
1933	INTEGER, INTENT(in) :: kumout
1934	lib_mpp_alloc = 0
1935	END FUNCTION lib_mpp_alloc
1936
1937	FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)
1938	INTEGER, OPTIONAL , INTENT(in ) :: localComm
1939	CHARACTER(len=*),DIMENSION(:) :: ldtxt
1940	CHARACTER(len=*) :: ldname
1941	INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop
1942	IF( PRESENT( localComm ) ) mpi_comm_opa = localComm
1943	function_value = 0
1944	IF( .FALSE. ) ldtxt(:) = 'never done'
1945	CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
1946	END FUNCTION mynode
1947
1948	SUBROUTINE mppsync ! Dummy routine
1949	END SUBROUTINE mppsync
1950
1951	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
1952	REAL , DIMENSION(:) :: parr
1953	INTEGER :: kdim
1954	INTEGER, OPTIONAL :: kcom
1955	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
1956	END SUBROUTINE mpp_sum_as
1957
1958	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
1959	REAL , DIMENSION(:,:) :: parr
1960	INTEGER :: kdim
1961	INTEGER, OPTIONAL :: kcom
1962	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
1963	END SUBROUTINE mpp_sum_a2s
1964
1965	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
1966	INTEGER, DIMENSION(:) :: karr
1967	INTEGER :: kdim
1968	INTEGER, OPTIONAL :: kcom
1969	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
1970	END SUBROUTINE mpp_sum_ai
1971
1972	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
1973	REAL :: psca
1974	INTEGER, OPTIONAL :: kcom
1975	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
1976	END SUBROUTINE mpp_sum_s
1977
1978	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
1979	integer :: kint
1980	INTEGER, OPTIONAL :: kcom
1981	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
1982	END SUBROUTINE mpp_sum_i
1983
1984	SUBROUTINE mppsum_realdd( ytab, kcom )
1985	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
1986	INTEGER , INTENT( in ), OPTIONAL :: kcom
1987	WRITE(,) 'mppsum_realdd: You should not have seen this print! error?', ytab
1988	END SUBROUTINE mppsum_realdd
1989
1990	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
1991	INTEGER , INTENT( in ) :: kdim ! size of ytab
1992	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
1993	INTEGER , INTENT( in ), OPTIONAL :: kcom
1994	WRITE(,) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
1995	END SUBROUTINE mppsum_a_realdd
1996
1997	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
1998	REAL , DIMENSION(:) :: parr
1999	INTEGER :: kdim
2000	INTEGER, OPTIONAL :: kcom
2001	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2002	END SUBROUTINE mppmax_a_real
2003
2004	SUBROUTINE mppmax_real( psca, kcom )
2005	REAL :: psca
2006	INTEGER, OPTIONAL :: kcom
2007	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
2008	END SUBROUTINE mppmax_real
2009
2010	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
2011	REAL , DIMENSION(:) :: parr
2012	INTEGER :: kdim
2013	INTEGER, OPTIONAL :: kcom
2014	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2015	END SUBROUTINE mppmin_a_real
2016
2017	SUBROUTINE mppmin_real( psca, kcom )
2018	REAL :: psca
2019	INTEGER, OPTIONAL :: kcom
2020	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
2021	END SUBROUTINE mppmin_real
2022
2023	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
2024	INTEGER, DIMENSION(:) :: karr
2025	INTEGER :: kdim
2026	INTEGER, OPTIONAL :: kcom
2027	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2028	END SUBROUTINE mppmax_a_int
2029
2030	SUBROUTINE mppmax_int( kint, kcom)
2031	INTEGER :: kint
2032	INTEGER, OPTIONAL :: kcom
2033	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
2034	END SUBROUTINE mppmax_int
2035
2036	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
2037	INTEGER, DIMENSION(:) :: karr
2038	INTEGER :: kdim
2039	INTEGER, OPTIONAL :: kcom
2040	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2041	END SUBROUTINE mppmin_a_int
2042
2043	SUBROUTINE mppmin_int( kint, kcom )
2044	INTEGER :: kint
2045	INTEGER, OPTIONAL :: kcom
2046	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
2047	END SUBROUTINE mppmin_int
2048
2049	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
2050	REAL :: pmin
2051	REAL , DIMENSION (:,:) :: ptab, pmask
2052	INTEGER :: ki, kj
2053	WRITE(,) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
2054	END SUBROUTINE mpp_minloc2d
2055
2056	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
2057	REAL :: pmin
2058	REAL , DIMENSION (:,:,:) :: ptab, pmask
2059	INTEGER :: ki, kj, kk
2060	WRITE(,) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2061	END SUBROUTINE mpp_minloc3d
2062
2063	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2064	REAL :: pmax
2065	REAL , DIMENSION (:,:) :: ptab, pmask
2066	INTEGER :: ki, kj
2067	WRITE(,) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
2068	END SUBROUTINE mpp_maxloc2d
2069
2070	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2071	REAL :: pmax
2072	REAL , DIMENSION (:,:,:) :: ptab, pmask
2073	INTEGER :: ki, kj, kk
2074	WRITE(,) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2075	END SUBROUTINE mpp_maxloc3d
2076
2077	SUBROUTINE mppstop
2078	STOP ! non MPP case, just stop the run
2079	END SUBROUTINE mppstop
2080
2081	SUBROUTINE mpp_ini_ice( kcom, knum )
2082	INTEGER :: kcom, knum
2083	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
2084	END SUBROUTINE mpp_ini_ice
2085
2086	SUBROUTINE mpp_ini_znl( knum )
2087	INTEGER :: knum
2088	WRITE(,) 'mpp_ini_znl: You should not have seen this print! error?', knum
2089	END SUBROUTINE mpp_ini_znl
2090
2091	SUBROUTINE mpp_comm_free( kcom )
2092	INTEGER :: kcom
2093	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?', kcom
2094	END SUBROUTINE mpp_comm_free
2095
2096	SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom )
2097	REAL, DIMENSION(:) :: ptab !
2098	INTEGER :: kdim !
2099	INTEGER, OPTIONAL :: kcom !
2100	WRITE(,) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim
2101	END SUBROUTINE mppmax_real_multiple
2102
2103	#endif
2104
2105	!!----------------------------------------------------------------------
2106	!! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines
2107	!!----------------------------------------------------------------------
2108
2109	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
2110	& cd6, cd7, cd8, cd9, cd10 )
2111	!!----------------------------------------------------------------------
2112	!! * ROUTINE stop_opa *
2113	!!
2114	!! ** Purpose : print in ocean.outpput file a error message and
2115	!! increment the error number (nstop) by one.
2116	!!----------------------------------------------------------------------
2117	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
2118	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
2119	!!----------------------------------------------------------------------
2120	!
2121	nstop = nstop + 1
2122	IF(lwp) THEN
2123	WRITE(numout,cform_err)
2124	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
2125	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
2126	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
2127	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
2128	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
2129	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
2130	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
2131	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
2132	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
2133	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
2134	ENDIF
2135	CALL FLUSH(numout )
2136	IF( numstp /= -1 ) CALL FLUSH(numstp )
2137	IF( numrun /= -1 ) CALL FLUSH(numrun )
2138	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
2139	!
2140	IF( cd1 == 'STOP' ) THEN
2141	IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
2142	CALL mppstop()
2143	ENDIF
2144	!
2145	END SUBROUTINE ctl_stop
2146
2147
2148	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
2149	& cd6, cd7, cd8, cd9, cd10 )
2150	!!----------------------------------------------------------------------
2151	!! * ROUTINE stop_warn *
2152	!!
2153	!! ** Purpose : print in ocean.outpput file a error message and
2154	!! increment the warning number (nwarn) by one.
2155	!!----------------------------------------------------------------------
2156	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
2157	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
2158	!!----------------------------------------------------------------------
2159	!
2160	nwarn = nwarn + 1
2161	IF(lwp) THEN
2162	WRITE(numout,cform_war)
2163	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
2164	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
2165	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
2166	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
2167	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
2168	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
2169	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
2170	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
2171	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
2172	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
2173	ENDIF
2174	CALL FLUSH(numout)
2175	!
2176	END SUBROUTINE ctl_warn
2177
2178
2179	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
2180	!!----------------------------------------------------------------------
2181	!! * ROUTINE ctl_opn *
2182	!!
2183	!! ** Purpose : Open file and check if required file is available.
2184	!!
2185	!! ** Method : Fortan open
2186	!!----------------------------------------------------------------------
2187	INTEGER , INTENT( out) :: knum ! logical unit to open
2188	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
2189	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
2190	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
2191	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
2192	INTEGER , INTENT(in ) :: klengh ! record length
2193	INTEGER , INTENT(in ) :: kout ! number of logical units for write
2194	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
2195	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
2196	!
2197	CHARACTER(len=80) :: clfile
2198	INTEGER :: iost
2199	!!----------------------------------------------------------------------
2200	!
2201	! adapt filename
2202	! ----------------
2203	clfile = TRIM(cdfile)
2204	IF( PRESENT( karea ) ) THEN
2205	IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
2206	ENDIF
2207	#if defined key_agrif
2208	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
2209	knum=Agrif_Get_Unit()
2210	#else
2211	knum=get_unit()
2212	#endif
2213	!
2214	iost=0
2215	IF( cdacce(1:6) == 'DIRECT' ) THEN
2216	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
2217	ELSE
2218	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
2219	ENDIF
2220	IF( iost == 0 ) THEN
2221	IF(ldwp) THEN
2222	WRITE(kout,*) ' file : ', clfile,' open ok'
2223	WRITE(kout,*) ' unit = ', knum
2224	WRITE(kout,*) ' status = ', cdstat
2225	WRITE(kout,*) ' form = ', cdform
2226	WRITE(kout,*) ' access = ', cdacce
2227	WRITE(kout,*)
2228	ENDIF
2229	ENDIF
2230	100 CONTINUE
2231	IF( iost /= 0 ) THEN
2232	IF(ldwp) THEN
2233	WRITE(kout,*)
2234	WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
2235	WRITE(kout,*) ' ======= === '
2236	WRITE(kout,*) ' unit = ', knum
2237	WRITE(kout,*) ' status = ', cdstat
2238	WRITE(kout,*) ' form = ', cdform
2239	WRITE(kout,*) ' access = ', cdacce
2240	WRITE(kout,*) ' iostat = ', iost
2241	WRITE(kout,*) ' we stop. verify the file '
2242	WRITE(kout,*)
2243	ENDIF
2244	CALL FLUSH(kout)
2245	CALL ctl_stop ('STOP', 'NEMO abort ctl_opn bad opening')
2246	ENDIF
2247	!
2248	END SUBROUTINE ctl_opn
2249
2250
2251	SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
2252	!!----------------------------------------------------------------------
2253	!! * ROUTINE ctl_nam *
2254	!!
2255	!! ** Purpose : Informations when error while reading a namelist
2256	!!
2257	!! ** Method : Fortan open
2258	!!----------------------------------------------------------------------
2259	INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist
2260	CHARACTER(len=*), INTENT(in ) :: cdnam ! group name of namelist for which error occurs
2261	CHARACTER(len=5) :: clios ! string to convert iostat in character for print
2262	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
2263	!!----------------------------------------------------------------------
2264	!
2265	WRITE (clios, '(I5.0)') kios
2266	IF( kios < 0 ) THEN
2267	CALL ctl_warn( 'end of record or file while reading namelist ' &
2268	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
2269	ENDIF
2270	!
2271	IF( kios > 0 ) THEN
2272	CALL ctl_stop( 'misspelled variable in namelist ' &
2273	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
2274	ENDIF
2275	kios = 0
2276	RETURN
2277	!
2278	END SUBROUTINE ctl_nam
2279
2280
2281	INTEGER FUNCTION get_unit()
2282	!!----------------------------------------------------------------------
2283	!! * FUNCTION get_unit *
2284	!!
2285	!! ** Purpose : return the index of an unused logical unit
2286	!!----------------------------------------------------------------------
2287	LOGICAL :: llopn
2288	!!----------------------------------------------------------------------
2289	!
2290	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
2291	llopn = .TRUE.
2292	DO WHILE( (get_unit < 998) .AND. llopn )
2293	get_unit = get_unit + 1
2294	INQUIRE( unit = get_unit, opened = llopn )
2295	END DO
2296	IF( (get_unit == 999) .AND. llopn ) THEN
2297	CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
2298	get_unit = -1
2299	ENDIF
2300	!
2301	END FUNCTION get_unit
2302
2303	!!----------------------------------------------------------------------
2304	END MODULE lib_mpp

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

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

Context Navigation

source: branches/UKMO/dev_r8126_LIM3_couple/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8879

Download in other formats: