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.

mpp.f90 in trunk/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: trunk/NEMOGCM/TOOLS/SIREN/src/mpp.f90 @ 5609

Last change on this file since 5609 was 5609, checked in by jpaul, 9 years ago
commit changes/bugfix/... for SIREN; see ticket #1580
File size: 127.2 KB

Line
1	!----------------------------------------------------------------------
2	! NEMO system team, System and Interface for oceanic RElocable Nesting
3	!----------------------------------------------------------------------
4	!
5	! MODULE: mpp
6	!
7	! DESCRIPTION:
8	!> @brief
9	!> This module manage massively parallel processing.
10	!
11	!> @details
12	!> define type TMPP:<br/>
13	!> @code
14	!> TYPE(TMPP) :: tl_mpp
15	!> @endcode
16	!>
17	!> to initialise a mpp structure:<br/>
18	!> @code
19	!> tl_mpp=mpp_init( cd_file, id_mask,
20	!> [id_niproc,] [id_njproc,] [id_nproc,]
21	!> [id_preci,] [id_precj,]
22	!> [cd_type,] [id_ew])
23	!> @endcode
24	!> or
25	!> @code
26	!> tl_mpp=mpp_init( cd_file, td_var,
27	!> [id_niproc,] [id_njproc,] [id_nproc,]
28	!> [id_preci,] [id_precj,]
29	!> [cd_type] )
30	!> @endcode
31	!> or
32	!> @code
33	!> tl_mpp=mpp_init( td_file [,id_ew] )
34	!> @endcode
35	!> - cd_file is the filename of the global domain file, in which
36	!> MPP will be done (example: Bathymetry)
37	!> - td_file is the file structure of one processor file composing an MPP
38	!> - id_mask is the 2D mask of global domain [optional]
39	!> - td_var is a variable structure (on T-point) from global domain file.
40	!> mask of the domain will be computed using FillValue [optional]
41	!> - id_niproc is the number of processor following I-direction to be used
42	!> [optional]
43	!> - id_njproc is the number of processor following J-direction to be used
44	!> [optional]
45	!> - id_nproc is the total number of processor to be used [optional]
46	!> - id_preci is the size of the overlap region following I-direction [optional]
47	!> - id_precj is the size of the overlap region following J-direction [optional]
48	!> - cd_type is the type of files composing MPP [optional]
49	!> - id_ew is east-west overlap [optional]<br/>
50	!>
51	!> to get mpp name:<br/>
52	!> - tl_mpp\%c_name
53	!>
54	!> to get the total number of processor:<br/>
55	!> - tl_mpp\%i_nproc
56	!>
57	!> to get the number of processor following I-direction:<br/>
58	!> - tl_mpp\%i_niproc
59	!>
60	!> to get the number of processor following J-direction:<br/>
61	!> - tl_mpp\%i_njproc
62	!>
63	!> to get the length of the overlap region following I-direction:<br/>
64	!> - tl_mpp\%i_preci
65	!>
66	!> to get the length of the overlap region following J-direction:<br/>
67	!> - tl_mpp\%i_precj
68	!>
69	!> to get the type of files composing mpp structure:<br/>
70	!> - tl_mpp\%c_type
71	!>
72	!> to get the type of the global domain:<br/>
73	!> - tl_mpp\%c_dom
74	!>
75	!> MPP dimensions (global domain)<br/>
76	!> to get the number of dimensions to be used in mpp strcuture:<br/>
77	!> - tl_mpp\%i_ndim
78	!>
79	!> to get the array of dimension structure (4 elts) associated to the
80	!> mpp structure:<br/>
81	!> - tl_mpp\%t_dim(:)
82	!>
83	!> MPP processor (files composing domain)<br/>
84	!> - tl_mpp\%t_proc(:)
85	!>
86	!> to clean a mpp structure:<br/>
87	!> @code
88	!> CALL mpp_clean(tl_mpp)
89	!> @endcode
90	!>
91	!> to print information about mpp:<br/>
92	!> @code
93	!> CALL mpp_print(tl_mpp)
94	!> @endcode
95	!>
96	!> to add variable to mpp:<br/>
97	!> @code
98	!> CALL mpp_add_var(td_mpp, td_var)
99	!> @endcode
100	!> - td_var is a variable structure
101	!>
102	!> to add dimension to mpp:<br/>
103	!> @code
104	!> CALL mpp_add_dim(td_mpp, td_dim)
105	!> @endcode
106	!> - td_dim is a dimension structure
107	!>
108	!> to add attribute to mpp:<br/>
109	!> @code
110	!> CALL mpp_add_att(td_mpp, td_att)
111	!> @endcode
112	!> - td_att is a attribute structure
113	!>
114	!> to delete variable from mpp:<br/>
115	!> @code
116	!> CALL mpp_del_var(td_mpp, td_var)
117	!> @endcode
118	!> or
119	!> @code
120	!> CALL mpp_del_var(td_mpp, cd_name)
121	!> @endcode
122	!> - td_var is a variable structure
123	!> - cd_name is variable name or standard name
124	!>
125	!> to delete dimension from mpp:<br/>
126	!> @code
127	!> CALL mpp_del_dim(td_mpp, td_dim)
128	!> @endcode
129	!> - td_dim is a dimension structure
130	!>
131	!> to delete attribute from mpp:<br/>
132	!> @code
133	!> CALL mpp_del_att(td_mpp, td_att)
134	!> @endcode
135	!> or
136	!> @code
137	!> CALL mpp_del_att(td_mpp, cd_name)
138	!> @endcode
139	!> - td_att is a attribute structure
140	!> - cd_name is attribute name
141	!>
142	!> to overwrite variable to mpp:<br/>
143	!> @code
144	!> CALL mpp_move_var(td_mpp, td_var)
145	!> @endcode
146	!> - td_var is a variable structure
147	!>
148	!> to overwrite dimension to mpp:<br/>
149	!> @code
150	!> CALL mpp_move_dim(td_mpp, td_dim)
151	!> @endcode
152	!> - td_dim is a dimension structure
153	!>
154	!> to overwrite attribute to mpp:<br/>
155	!> @code
156	!> CALL mpp_move_att(td_mpp, td_att)
157	!> @endcode
158	!> - td_att is a attribute structure
159	!>
160	!> to determine domain decomposition type:<br/>
161	!> @code
162	!> CALL mpp_get_dom(td_mpp)
163	!> @endcode
164	!>
165	!> to get processors to be used:<br/>
166	!> @code
167	!> CALL mpp_get_use( td_mpp, id_imin, id_imax, &
168	!> & id_jmin, id_jmax )
169	!> @endcode
170	!> - id_imin
171	!> - id_imax
172	!> - id_jmin
173	!> - id_jmax
174	!>
175	!> to get sub domains which form global domain contour:<br/>
176	!> @code
177	!> CALL mpp_get_contour( td_mpp )
178	!> @endcode
179	!>
180	!> to get global domain indices of one processor:<br/>
181	!> @code
182	!> il_ind(1:4)=mpp_get_proc_index( td_mpp, id_procid )
183	!> @endcode
184	!> - il_ind(1:4) are global domain indices (i1,i2,j1,j2)
185	!> - id_procid is the processor id
186	!>
187	!> to get the processor domain size:<br/>
188	!> @code
189	!> il_size(1:2)=mpp_get_proc_size( td_mpp, id_procid )
190	!> @endcode
191	!> - il_size(1:2) are the size of domain following I and J
192	!> - id_procid is the processor id
193	!>
194	!> @author
195	!> J.Paul
196	! REVISION HISTORY:
197	!> @date November, 2013 - Initial Version
198	!> @date November, 2014 - Fix memory leaks bug
199	!
200	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
201	!----------------------------------------------------------------------
202	MODULE mpp
203	USE global ! global parameter
204	USE kind ! F90 kind parameter
205	USE logger ! log file manager
206	USE fct ! basic useful function
207	USE dim ! dimension manager
208	USE att ! attribute manager
209	USE var ! variable manager
210	USE file ! file manager
211	USE iom ! I/O manager
212	IMPLICIT NONE
213	! NOTE_avoid_public_variables_if_possible
214
215	! type and variable
216	PUBLIC :: TMPP !< mpp structure
217
218	! function and subroutine
219	PUBLIC :: mpp_copy !< copy mpp structure
220	PUBLIC :: mpp_init !< initialise mpp structure
221	PUBLIC :: mpp_clean !< clean mpp strcuture
222	PUBLIC :: mpp_print !< print information about mpp structure
223	PUBLIC :: mpp_add_var !< split/add one variable strucutre in mpp structure
224	PUBLIC :: mpp_add_dim !< add one dimension to mpp structure
225	PUBLIC :: mpp_add_att !< add one attribute strucutre in mpp structure
226	PUBLIC :: mpp_del_var !< delete one variable strucutre in mpp structure
227	PUBLIC :: mpp_del_dim !< delete one dimension strucutre in mpp structure
228	PUBLIC :: mpp_del_att !< delete one attribute strucutre in mpp structure
229	PUBLIC :: mpp_move_var !< overwrite variable structure in mpp structure
230	PUBLIC :: mpp_move_dim !< overwrite one dimension strucutre in mpp structure
231	PUBLIC :: mpp_move_att !< overwrite one attribute strucutre in mpp structure
232	PUBLIC :: mpp_recombine_var !< recombine variable from mpp structure
233	PUBLIC :: mpp_get_index !< return index of mpp
234
235	PUBLIC :: mpp_get_dom !< determine domain decomposition type (full, overlap, noverlap)
236	PUBLIC :: mpp_get_use !< get sub domains to be used (which cover "zoom domain")
237	PUBLIC :: mpp_get_contour !< get sub domains which form global domain contour
238	PUBLIC :: mpp_get_proc_index !< get processor domain indices
239	PUBLIC :: mpp_get_proc_size !< get processor domain size
240
241	PRIVATE :: mpp__add_proc ! add one proc strucutre in mpp structure
242	PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure
243	PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id
244	PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure
245	PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure
246	PRIVATE :: mpp__compute ! compute domain decomposition
247	PRIVATE :: mpp__del_land ! remove land sub domain from domain decomposition
248	PRIVATE :: mpp__optimiz ! compute optimum domain decomposition
249	PRIVATE :: mpp__land_proc ! check if processor is a land processor
250	PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension
251	PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension
252	PRIVATE :: mpp__check_var_dim ! check if variable and mpp structure use same dimension
253	PRIVATE :: mpp__del_var_name ! delete variable in mpp structure, given variable name
254	PRIVATE :: mpp__del_var_mpp ! delete all variable in mpp structure
255	PRIVATE :: mpp__del_var_str ! delete variable in mpp structure, given variable structure
256	PRIVATE :: mpp__del_att_name ! delete variable in mpp structure, given variable name
257	PRIVATE :: mpp__del_att_str ! delete variable in mpp structure, given variable structure
258	PRIVATE :: mpp__split_var ! extract variable part that will be written in processor
259	PRIVATE :: mpp__copy_unit ! copy mpp structure
260	PRIVATE :: mpp__copy_arr ! copy array of mpp structure
261	PRIVATE :: mpp__get_use_unit ! get sub domains to be used (which cover "zoom domain")
262	PRIVATE :: mpp__init_mask ! initialise mpp structure, given file name
263	PRIVATE :: mpp__init_var ! initialise mpp structure, given variable strcuture
264	PRIVATE :: mpp__init_file ! initialise a mpp structure, given file structure
265	PRIVATE :: mpp__init_file_cdf ! initialise a mpp structure with cdf file
266	PRIVATE :: mpp__init_file_rstdimg ! initialise a mpp structure with rstdimg file
267	PRIVATE :: mpp__clean_unit ! clean mpp strcuture
268	PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture
269
270	TYPE TMPP !< mpp structure
271
272	! general
273	CHARACTER(LEN=lc) :: c_name = '' !< base name
274	INTEGER(i4) :: i_id = 0 !< mpp id
275
276	INTEGER(i4) :: i_niproc = 0 !< number of processors following i
277	INTEGER(i4) :: i_njproc = 0 !< number of processors following j
278	INTEGER(i4) :: i_nproc = 0 !< total number of proccessors used
279	INTEGER(i4) :: i_preci = 1 !< i-direction overlap region length
280	INTEGER(i4) :: i_precj = 1 !< j-direction overlap region length
281	INTEGER(i4) :: i_ew = -1 !< east-west overlap
282	INTEGER(i4) :: i_perio = -1 !< NEMO periodicity index
283	INTEGER(i4) :: i_pivot = -1 !< NEMO pivot point index F(0),T(1)
284
285	CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg)
286	CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, nooverlap)
287
288	INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp
289	TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension
290
291	TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp
292
293	END TYPE
294
295	INTERFACE mpp_get_use
296	MODULE PROCEDURE mpp__get_use_unit
297	END INTERFACE mpp_get_use
298
299	INTERFACE mpp_clean
300	MODULE PROCEDURE mpp__clean_unit
301	MODULE PROCEDURE mpp__clean_arr
302	END INTERFACE mpp_clean
303
304	INTERFACE mpp__check_dim
305	MODULE PROCEDURE mpp__check_proc_dim !< check if processor and mpp structure use same dimension
306	MODULE PROCEDURE mpp__check_var_dim !< check if variable and mpp structure use same dimension
307	END INTERFACE mpp__check_dim
308
309	INTERFACE mpp__del_proc
310	MODULE PROCEDURE mpp__del_proc_id
311	MODULE PROCEDURE mpp__del_proc_str
312	END INTERFACE mpp__del_proc
313
314	INTERFACE mpp_del_var
315	MODULE PROCEDURE mpp__del_var_name
316	MODULE PROCEDURE mpp__del_var_str
317	MODULE PROCEDURE mpp__del_var_mpp
318	END INTERFACE mpp_del_var
319
320	INTERFACE mpp_del_att
321	MODULE PROCEDURE mpp__del_att_name
322	MODULE PROCEDURE mpp__del_att_str
323	END INTERFACE mpp_del_att
324
325	INTERFACE mpp_init
326	MODULE PROCEDURE mpp__init_mask
327	MODULE PROCEDURE mpp__init_var
328	MODULE PROCEDURE mpp__init_file
329	END INTERFACE mpp_init
330
331	INTERFACE mpp_copy
332	MODULE PROCEDURE mpp__copy_unit ! copy mpp structure
333	MODULE PROCEDURE mpp__copy_arr ! copy array of mpp structure
334	END INTERFACE
335
336	CONTAINS
337	!-------------------------------------------------------------------
338	!> @brief
339	!> This subroutine copy mpp structure in another one
340	!> @details
341	!> mpp file are copied in a temporary array,
342	!> so input and output mpp structure do not point on the same
343	!> "memory cell", and so on are independant.
344	!>
345	!> @warning do not use on the output of a function who create or read an
346	!> structure (ex: tl_file=file_copy(file_init()) is forbidden).
347	!> This will create memory leaks.
348	!> @warning to avoid infinite loop, do not use any function inside
349	!> this subroutine
350	!>
351	!> @author J.Paul
352	!> - November, 2013- Initial Version
353	!> @date November, 2014
354	!> - use function instead of overload assignment operator
355	!> (to avoid memory leak)
356	!
357	!> @param[in] td_mpp mpp structure
358	!> @return copy of input mpp structure
359	!-------------------------------------------------------------------
360	FUNCTION mpp__copy_unit( td_mpp )
361	IMPLICIT NONE
362	! Argument
363	TYPE(TMPP), INTENT(IN) :: td_mpp
364	! function
365	TYPE(TMPP) :: mpp__copy_unit
366
367	! local variable
368	TYPE(TFILE) :: tl_file
369
370	! loop indices
371	INTEGER(i4) :: ji
372	!----------------------------------------------------------------
373
374	CALL logger_trace("MPP COPY: "//TRIM(td_mpp%c_name)//" in "//&
375	& TRIM(mpp__copy_unit%c_name))
376
377	! copy mpp variable
378	mpp__copy_unit%c_name = TRIM(td_mpp%c_name)
379	mpp__copy_unit%i_id = td_mpp%i_id
380	mpp__copy_unit%i_niproc = td_mpp%i_niproc
381	mpp__copy_unit%i_njproc = td_mpp%i_njproc
382	mpp__copy_unit%i_nproc = td_mpp%i_nproc
383	mpp__copy_unit%i_preci = td_mpp%i_preci
384	mpp__copy_unit%i_precj = td_mpp%i_precj
385	mpp__copy_unit%c_type = TRIM(td_mpp%c_type)
386	mpp__copy_unit%c_dom = TRIM(td_mpp%c_dom)
387	mpp__copy_unit%i_ndim = td_mpp%i_ndim
388	mpp__copy_unit%i_ew = td_mpp%i_ew
389	mpp__copy_unit%i_perio = td_mpp%i_perio
390	mpp__copy_unit%i_pivot = td_mpp%i_pivot
391
392	! copy dimension
393	mpp__copy_unit%t_dim(:) = dim_copy(td_mpp%t_dim(:))
394
395	! copy file structure
396	IF( ASSOCIATED(mpp__copy_unit%t_proc) )THEN
397	CALL file_clean(mpp__copy_unit%t_proc(:))
398	DEALLOCATE(mpp__copy_unit%t_proc)
399	ENDIF
400	IF( ASSOCIATED(td_mpp%t_proc) .AND. mpp__copy_unit%i_nproc > 0 )THEN
401	ALLOCATE( mpp__copy_unit%t_proc(mpp__copy_unit%i_nproc) )
402	DO ji=1,mpp__copy_unit%i_nproc
403	tl_file = file_copy(td_mpp%t_proc(ji))
404	mpp__copy_unit%t_proc(ji) = file_copy(tl_file)
405	ENDDO
406	! clean
407	CALL file_clean(tl_file)
408	ENDIF
409
410	END FUNCTION mpp__copy_unit
411	!-------------------------------------------------------------------
412	!> @brief
413	!> This subroutine copy an array of mpp structure in another one
414	!> @details
415	!> mpp file are copied in a temporary array,
416	!> so input and output mpp structure do not point on the same
417	!> "memory cell", and so on are independant.
418	!>
419	!> @warning do not use on the output of a function who create or read an
420	!> structure (ex: tl_file=file_copy(file_init()) is forbidden).
421	!> This will create memory leaks.
422	!> @warning to avoid infinite loop, do not use any function inside
423	!> this subroutine
424	!>
425	!> @author J.Paul
426	!> - November, 2013- Initial Version
427	!> @date November, 2014
428	!> - use function instead of overload assignment operator
429	!> (to avoid memory leak)
430	!>
431	!> @param[in] td_mpp mpp structure
432	!> @return copy of input array of mpp structure
433	!-------------------------------------------------------------------
434	FUNCTION mpp__copy_arr( td_mpp )
435	IMPLICIT NONE
436	! Argument
437	TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp
438	! function
439	TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: mpp__copy_arr
440
441	! local variable
442	! loop indices
443	INTEGER(i4) :: ji
444	!----------------------------------------------------------------
445
446	DO ji=1,SIZE(td_mpp(:))
447	mpp__copy_arr(ji)=mpp_copy(td_mpp(ji))
448	ENDDO
449
450	END FUNCTION mpp__copy_arr
451	!-------------------------------------------------------------------
452	!> @brief This subroutine print some information about mpp strucutre.
453	!
454	!> @author J.Paul
455	!> - Nov, 2013- Initial Version
456	!
457	!> @param[in] td_mpp mpp structure
458	!-------------------------------------------------------------------
459	SUBROUTINE mpp_print(td_mpp)
460	IMPLICIT NONE
461
462	! Argument
463	TYPE(TMPP), INTENT(IN) :: td_mpp
464
465	! local variable
466	INTEGER(i4), PARAMETER :: il_freq = 4
467
468	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_proc
469	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lci
470	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lcj
471
472	! loop indices
473	INTEGER(i4) :: ji
474	INTEGER(i4) :: jj
475	INTEGER(i4) :: jk
476	INTEGER(i4) :: jl
477	INTEGER(i4) :: jm
478	!----------------------------------------------------------------
479
480	WRITE(*,'((a,a),2(/3x,a,a),9(/3x,a,i0))')&
481	& "MPP : ",TRIM(td_mpp%c_name), &
482	& " type : ",TRIM(td_mpp%c_type), &
483	& " dom : ",TRIM(td_mpp%c_dom), &
484	& " nproc : ",td_mpp%i_nproc, &
485	& " niproc : ",td_mpp%i_niproc, &
486	& " njproc : ",td_mpp%i_njproc, &
487	& " preci : ",td_mpp%i_preci, &
488	& " precj : ",td_mpp%i_precj, &
489	& " ndim : ",td_mpp%i_ndim, &
490	& " overlap: ",td_mpp%i_ew, &
491	& " perio : ",td_mpp%i_perio, &
492	& " pivot : ",td_mpp%i_pivot
493
494	! print dimension
495	IF( td_mpp%i_ndim /= 0 )THEN
496	WRITE(*,'(/a)') " MPP dimension"
497	DO ji=1,ip_maxdim
498	IF( td_mpp%t_dim(ji)%l_use )THEN
499	CALL dim_print(td_mpp%t_dim(ji))
500	ENDIF
501	ENDDO
502	ENDIF
503
504	! print file
505	IF( td_mpp%i_nproc /= 0 .AND. ASSOCIATED(td_mpp%t_proc) )THEN
506	IF( ALL( td_mpp%t_proc(:)%i_iind==0 ) .OR. &
507	& ALL( td_mpp%t_proc(:)%i_jind==0 ) )THEN
508
509	DO ji=1,td_mpp%i_nproc
510	CALL file_print(td_mpp%t_proc(ji))
511	WRITE(*,'((a),(/3x,a,i0),2(/3x,a,a),4(/3x,a,i0,a,i0)/)')&
512	& " Domain decomposition : ", &
513	& " id : ",td_mpp%t_proc(ji)%i_pid, &
514	& " used : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_use)), &
515	& " contour : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_ctr)), &
516	& " left-bottom : ",td_mpp%t_proc(ji)%i_impp,', ',&
517	& td_mpp%t_proc(ji)%i_jmpp, &
518	& " dimension : ",td_mpp%t_proc(ji)%i_lci,' x ',&
519	& td_mpp%t_proc(ji)%i_lcj, &
520	& " first indoor indices : ",td_mpp%t_proc(ji)%i_ldi,', ',&
521	& td_mpp%t_proc(ji)%i_ldj, &
522	& " last indoor indices : ",td_mpp%t_proc(ji)%i_lei,', ',&
523	& td_mpp%t_proc(ji)%i_lej
524
525	ENDDO
526
527	IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN
528	WRITE(*,'(/a)') " Variable(s) used : "
529	DO ji=1,td_mpp%t_proc(1)%i_nvar
530	WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)
531	ENDDO
532	ENDIF
533
534	ELSE
535
536	DO ji=1,td_mpp%i_nproc
537	WRITE(*,'((a, a),(/3x,a,i0),(/3x,a,a),4(/3x,a,i0,a,i0)/)')&
538	& " Domain decomposition : ",TRIM(td_mpp%t_proc(ji)%c_name),&
539	& " id : ",td_mpp%t_proc(ji)%i_pid, &
540	& " used : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_use)),&
541	& " left-bottom : ",td_mpp%t_proc(ji)%i_impp,', ',&
542	& td_mpp%t_proc(ji)%i_jmpp, &
543	& " dimension : ",td_mpp%t_proc(ji)%i_lci,' x ',&
544	& td_mpp%t_proc(ji)%i_lcj, &
545	& " first indoor indices : ",td_mpp%t_proc(ji)%i_ldi,',',&
546	& td_mpp%t_proc(ji)%i_ldj, &
547	& " last indoor indices : ",td_mpp%t_proc(ji)%i_lei,', ',&
548	& td_mpp%t_proc(ji)%i_lej
549
550	ENDDO
551
552	IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN
553	WRITE(*,'(/a)') " Variable(s) used : "
554	DO ji=1,td_mpp%t_proc(1)%i_nvar
555	WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)
556	ENDDO
557	ENDIF
558
559	ALLOCATE( il_proc(td_mpp%i_niproc,td_mpp%i_njproc) )
560	ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) )
561	ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) )
562
563	DO jk=1,td_mpp%i_nproc
564	ji=td_mpp%t_proc(jk)%i_iind
565	jj=td_mpp%t_proc(jk)%i_jind
566	il_proc(ji,jj)=jk
567	il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci
568	il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj
569	ENDDO
570
571	jl = 1
572	DO jk = 1,(td_mpp%i_niproc-1)/il_freq+1
573	jm = MIN(td_mpp%i_niproc, jl+il_freq-1)
574	WRITE(,)
575	WRITE(*,9401) (ji, ji = jl,jm)
576	WRITE(,9400) ('**', ji = jl,jm-1)
577	DO jj = 1, td_mpp%i_njproc
578	WRITE(*,9403) (' ', ji = jl,jm-1)
579	WRITE(*,9402) jj, ( il_lci(ji,jj), il_lcj(ji,jj), ji = jl,jm)
580	WRITE(*,9404) (il_proc(ji,jj), ji= jl,jm)
581	WRITE(*,9403) (' ', ji = jl,jm-1)
582	WRITE(,9400) ('**', ji = jl,jm-1)
583	ENDDO
584	jl = jl+il_freq
585	ENDDO
586
587	DEALLOCATE( il_proc )
588	DEALLOCATE( il_lci )
589	DEALLOCATE( il_lcj )
590
591	ENDIF
592	ELSE
593	WRITE(*,'(/a)') " Domain decomposition : none"
594	ENDIF
595
596
597	9400 FORMAT(' *',20('***********',a3))
598	9403 FORMAT(' * ',20(' * ',a3))
599	9401 FORMAT(' ',20(' ',i3,' '))
600	9402 FORMAT(' ',i3,' * ',20(i0,' x',i0,' * '))
601	9404 FORMAT(' * ',20(' ',i3,' * '))
602
603	END SUBROUTINE mpp_print
604	!-------------------------------------------------------------------
605	!> @brief
606	!> This function initialise mpp structure, given file name,
607	!> and optionaly mask and number of processor following I and J
608	!> @detail
609	!> - If no total number of processor is defined (id_nproc), optimize
610	!> the domain decomposition (look for the domain decomposition with
611	!> the most land processor to remove)
612	!> - length of the overlap region (id_preci, id_precj) could be specify
613	!> in I and J direction (default value is 1)
614	!
615	!> @author J.Paul
616	!> @date November, 2013 - Initial version
617	!
618	!> @param[in] cd_file file name of one file composing mpp domain
619	!> @param[in] id_mask domain mask
620	!> @param[in] id_niproc number of processors following i
621	!> @param[in] id_njproc number of processors following j
622	!> @param[in] id_nproc total number of processors
623	!> @param[in] id_preci i-direction overlap region
624	!> @param[in] id_precj j-direction overlap region
625	!> @param[in] cd_type type of the files (cdf, cdf4, dimg)
626	!> @param[in] id_ew east-west overlap
627	!> @param[in] id_perio NEMO periodicity index
628	!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
629	!> @return mpp structure
630	!-------------------------------------------------------------------
631	TYPE(TMPP) FUNCTION mpp__init_mask(cd_file, id_mask, &
632	& id_niproc, id_njproc, id_nproc,&
633	& id_preci, id_precj, &
634	cd_type, id_ew, id_perio, id_pivot)
635	IMPLICIT NONE
636	! Argument
637	CHARACTER(LEN=*), INTENT(IN) :: cd_file
638	INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
639	INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc
640	INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc
641	INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc
642	INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci
643	INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj
644	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
645	INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
646	INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
647	INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
648
649	! local variable
650	CHARACTER(LEN=lc) :: cl_type
651
652	INTEGER(i4) , DIMENSION(2) :: il_shape
653
654	TYPE(TDIM) :: tl_dim
655
656	TYPE(TATT) :: tl_att
657	! loop indices
658	INTEGER(i4) :: ji
659	!----------------------------------------------------------------
660
661	! clean mpp
662	CALL mpp_clean(mpp__init_mask)
663
664	! check type
665	cl_type=''
666	IF( PRESENT(cd_type) ) cl_type=TRIM(ADJUSTL(cd_type))
667
668	IF( TRIM(cl_type) /= '' )THEN
669	SELECT CASE(TRIM(cd_type))
670	CASE('cdf')
671	mpp__init_mask%c_type='cdf'
672	CASE('dimg')
673	mpp__init_mask%c_type='dimg'
674	CASE DEFAULT
675	CALL logger_warn( "MPP INIT: type "//TRIM(cd_type)//&
676	& " unknown. type dimg will be used for mpp "//&
677	& TRIM(mpp__init_mask%c_name) )
678	mpp__init_mask%c_type='dimg'
679	END SELECT
680	ELSE
681	mpp__init_mask%c_type=TRIM(file_get_type(cd_file))
682	ENDIF
683
684	! get mpp name
685	mpp__init_mask%c_name=TRIM(file_rename(cd_file))
686
687	! get global domain dimension
688	il_shape(:)=SHAPE(id_mask)
689
690	tl_dim=dim_init('X',il_shape(1))
691	CALL mpp_add_dim(mpp__init_mask, tl_dim)
692
693	tl_dim=dim_init('Y',il_shape(2))
694	CALL mpp_add_dim(mpp__init_mask, tl_dim)
695
696	! clean
697	CALL dim_clean(tl_dim)
698
699	IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. &
700	((.NOT. PRESENT(id_niproc)) .AND. PRESENT(id_njproc) ) )THEN
701	CALL logger_warn( "MPP INIT: number of processors following I and J "//&
702	& "should be both specified")
703	ELSE
704	! get number of processors following I and J
705	IF( PRESENT(id_niproc) ) mpp__init_mask%i_niproc=id_niproc
706	IF( PRESENT(id_njproc) ) mpp__init_mask%i_njproc=id_njproc
707	ENDIF
708
709	! get maximum number of processors to be used
710	IF( PRESENT(id_nproc) ) mpp__init_mask%i_nproc = id_nproc
711
712	! get overlap region length
713	IF( PRESENT(id_preci) ) mpp__init_mask%i_preci= id_preci
714	IF( PRESENT(id_precj) ) mpp__init_mask%i_precj= id_precj
715
716	! east-west overlap
717	IF( PRESENT(id_ew) ) mpp__init_mask%i_ew= id_ew
718	! NEMO periodicity
719	IF( PRESENT(id_perio) ) mpp__init_mask%i_perio= id_perio
720	IF( PRESENT(id_pivot) ) mpp__init_mask%i_pivot= id_pivot
721
722	IF( mpp__init_mask%i_nproc /= 0 .AND. &
723	& mpp__init_mask%i_niproc /= 0 .AND. &
724	& mpp__init_mask%i_njproc /= 0 .AND. &
725	& mpp__init_mask%i_nproc > &
726	& mpp__init_mask%i_niproc * mpp__init_mask%i_njproc )THEN
727
728	CALL logger_error("MPP INIT: invalid domain decomposition ")
729	CALL logger_debug("MPP INIT: "// &
730	& TRIM(fct_str(mpp__init_mask%i_nproc))//" > "//&
731	& TRIM(fct_str(mpp__init_mask%i_niproc))//" x "//&
732	& TRIM(fct_str(mpp__init_mask%i_njproc)) )
733
734	ELSE
735
736	IF( mpp__init_mask%i_niproc /= 0 .AND. &
737	& mpp__init_mask%i_njproc /= 0 )THEN
738	! compute domain decomposition
739	CALL mpp__compute( mpp__init_mask )
740	! remove land sub domain
741	CALL mpp__del_land( mpp__init_mask, id_mask )
742	ELSEIF( mpp__init_mask%i_nproc /= 0 )THEN
743	! optimiz
744	CALL mpp__optimiz( mpp__init_mask, id_mask )
745
746	ELSE
747	CALL logger_warn("MPP INIT: number of processor to be used "//&
748	& "not specify. force to one.")
749	mpp__init_mask%i_nproc = 1
750	! optimiz
751	CALL mpp__optimiz( mpp__init_mask, id_mask )
752	ENDIF
753	CALL logger_info("MPP INIT: domain decoposition : "//&
754	& 'niproc('//TRIM(fct_str(mpp__init_mask%i_niproc))//') * '//&
755	& 'njproc('//TRIM(fct_str(mpp__init_mask%i_njproc))//') = '//&
756	& 'nproc('//TRIM(fct_str(mpp__init_mask%i_nproc))//')' )
757
758	! get domain type
759	CALL mpp_get_dom( mpp__init_mask )
760
761	DO ji=1,mpp__init_mask%i_nproc
762
763	! get processor size
764	il_shape(:)=mpp_get_proc_size( mpp__init_mask, ji )
765
766	tl_dim=dim_init('X',il_shape(1))
767	CALL file_move_dim(mpp__init_mask%t_proc(ji), tl_dim)
768
769	tl_dim=dim_init('Y',il_shape(2))
770	CALL file_move_dim(mpp__init_mask%t_proc(ji), tl_dim)
771
772	! add type
773	mpp__init_mask%t_proc(ji)%c_type=TRIM(mpp__init_mask%c_type)
774
775	! clean
776	CALL dim_clean(tl_dim)
777	ENDDO
778
779	! add global attribute
780	tl_att=att_init("DOMAIN_number_total",mpp__init_mask%i_nproc)
781	CALL mpp_add_att(mpp__init_mask, tl_att)
782
783	tl_att=att_init("DOMAIN_I_number_total",mpp__init_mask%i_niproc)
784	CALL mpp_add_att(mpp__init_mask, tl_att)
785
786	tl_att=att_init("DOMAIN_J_number_total",mpp__init_mask%i_njproc)
787	CALL mpp_add_att(mpp__init_mask, tl_att)
788
789	tl_att=att_init("DOMAIN_size_global",mpp__init_mask%t_dim(1:2)%i_len)
790	CALL mpp_add_att(mpp__init_mask, tl_att)
791
792	tl_att=att_init( "DOMAIN_I_position_first", &
793	& mpp__init_mask%t_proc(:)%i_impp )
794	CALL mpp_add_att(mpp__init_mask, tl_att)
795
796	tl_att=att_init( "DOMAIN_J_position_first", &
797	& mpp__init_mask%t_proc(:)%i_jmpp )
798	CALL mpp_add_att(mpp__init_mask, tl_att)
799
800	tl_att=att_init( "DOMAIN_I_position_last", &
801	& mpp__init_mask%t_proc(:)%i_lci )
802	CALL mpp_add_att(mpp__init_mask, tl_att)
803
804	tl_att=att_init( "DOMAIN_J_position_last", &
805	& mpp__init_mask%t_proc(:)%i_lcj )
806	CALL mpp_add_att(mpp__init_mask, tl_att)
807
808	tl_att=att_init( "DOMAIN_I_halo_size_start", &
809	& mpp__init_mask%t_proc(:)%i_ldi )
810	CALL mpp_add_att(mpp__init_mask, tl_att)
811
812	tl_att=att_init( "DOMAIN_J_halo_size_start", &
813	& mpp__init_mask%t_proc(:)%i_ldj )
814	CALL mpp_add_att(mpp__init_mask, tl_att)
815
816	tl_att=att_init( "DOMAIN_I_halo_size_end", &
817	& mpp__init_mask%t_proc(:)%i_lei )
818	CALL mpp_add_att(mpp__init_mask, tl_att)
819
820	tl_att=att_init( "DOMAIN_J_halo_size_end", &
821	& mpp__init_mask%t_proc(:)%i_lej )
822	CALL mpp_add_att(mpp__init_mask, tl_att)
823
824	! clean
825	CALL att_clean(tl_att)
826	ENDIF
827
828	END FUNCTION mpp__init_mask
829	!-------------------------------------------------------------------
830	!> @brief
831	!> This function initialise mpp structure, given variable strcuture
832	!> and optionaly number of processor following I and J
833	!> @detail
834	!> - If no total number of processor is defined (id_nproc), optimize
835	!> the domain decomposition (look for the domain decomposition with
836	!> the most land processor to remove)
837	!> - length of the overlap region (id_preci, id_precj) could be specify
838	!> in I and J direction (default value is 1)
839	!
840	!> @author J.Paul
841	!> @date November, 2013 - Initial version
842	!
843	!> @param[in] cd_file file name of one file composing mpp domain
844	!> @param[in] td_var variable structure
845	!> @param[in] id_niproc number of processors following i
846	!> @param[in] id_njproc number of processors following j
847	!> @param[in] id_nproc total number of processors
848	!> @param[in] id_preci i-direction overlap region
849	!> @param[in] id_precj j-direction overlap region
850	!> @param[in] cd_type type of the files (cdf, cdf4, dimg)
851	!> @param[in] id_perio NEMO periodicity index
852	!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
853	!> @return mpp structure
854	!-------------------------------------------------------------------
855	TYPE(TMPP) FUNCTION mpp__init_var( cd_file, td_var, &
856	& id_niproc, id_njproc, id_nproc,&
857	& id_preci, id_precj, cd_type, &
858	& id_perio, id_pivot )
859	IMPLICIT NONE
860	! Argument
861	CHARACTER(LEN=*), INTENT(IN) :: cd_file
862	TYPE(TVAR), INTENT(IN) :: td_var
863	INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc
864	INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc
865	INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc
866	INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci
867	INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj
868	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
869	INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
870	INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
871
872	! local variable
873	INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_mask
874	!----------------------------------------------------------------
875
876	IF( ASSOCIATED(td_var%d_value) )THEN
877	ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
878	& td_var%t_dim(2)%i_len, &
879	& td_var%t_dim(3)%i_len) )
880	il_mask(:,:,:)=var_get_mask(td_var)
881
882	mpp__init_var=mpp_init( cd_file, il_mask(:,:,1), &
883	& id_niproc, id_njproc, id_nproc,&
884	& id_preci, id_precj, cd_type, &
885	& id_ew=td_var%i_ew, &
886	& id_perio=id_perio, id_pivot=id_pivot)
887
888	DEALLOCATE(il_mask)
889	ELSE
890	CALL logger_error("MPP INIT: variable value not define.")
891	ENDIF
892
893	END FUNCTION mpp__init_var
894	!-------------------------------------------------------------------
895	!> @brief This function initalise a mpp structure given file structure.
896	!> @details
897	!> It reads restart dimg files, or some netcdf files.
898	!>
899	!> @warning
900	!> netcdf file must contains some attributes:
901	!> - DOMAIN_number_total
902	!> - DOMAIN_size_global
903	!> - DOMAIN_number
904	!> - DOMAIN_position_first
905	!> - DOMAIN_position_last
906	!> - DOMAIN_halo_size_start
907	!> - DOMAIN_halo_size_end
908	!> or the file is assume to be no mpp file.
909	!>
910	!>
911	!>
912	!> @author J.Paul
913	!> - November, 2013- Initial Version
914	!
915	!> @param[in] td_file file strcuture
916	!> @param[in] id_ew east-west overlap
917	!> @param[in] id_perio NEMO periodicity index
918	!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
919	!> @return mpp structure
920	!-------------------------------------------------------------------
921	TYPE(TMPP) FUNCTION mpp__init_file( td_file, id_ew, id_perio, id_pivot )
922	IMPLICIT NONE
923
924	! Argument
925	TYPE(TFILE), INTENT(IN) :: td_file
926	INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
927	INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
928	INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
929
930	! local variable
931	TYPE(TMPP) :: tl_mpp
932
933	TYPE(TFILE) :: tl_file
934
935	TYPE(TDIM) :: tl_dim
936
937	TYPE(TATT) :: tl_att
938
939	INTEGER(i4) :: il_nproc
940	INTEGER(i4) :: il_attid
941
942	INTEGER(i4), DIMENSION(2) :: il_shape
943	! loop indices
944	INTEGER(i4) :: ji
945	!----------------------------------------------------------------
946
947	! clean mpp
948	CALL mpp_clean(mpp__init_file)
949
950	! check file type
951	SELECT CASE( TRIM(td_file%c_type) )
952	CASE('cdf')
953	! need to read all file to get domain decomposition
954	tl_file=file_copy(td_file)
955
956	! open file
957	CALL iom_open(tl_file)
958
959	! read first file domain decomposition
960	tl_mpp=mpp__init_file_cdf(tl_file)
961
962	! get number of processor/file to be read
963	il_nproc = 1
964	il_attid = 0
965
966	IF( ASSOCIATED(tl_file%t_att) )THEN
967	il_attid=att_get_id( tl_file%t_att, "DOMAIN_number_total" )
968	ENDIF
969	IF( il_attid /= 0 )THEN
970	il_nproc = INT(tl_file%t_att(il_attid)%d_value(1))
971	ENDIF
972
973	! close file
974	CALL iom_close(tl_file)
975
976	IF( il_nproc /= 1 )THEN
977	DO ji=1,il_nproc
978
979	! clean mpp strcuture
980	CALL mpp_clean(tl_mpp)
981
982	! get filename
983	tl_file=file_rename(td_file,ji)
984
985	! open file
986	CALL iom_open(tl_file)
987
988	! read domain decomposition
989	tl_mpp = mpp__init_file_cdf(tl_file)
990	IF( ji == 1 )THEN
991	mpp__init_file=mpp_copy(tl_mpp)
992	ELSE
993	IF( ANY( mpp__init_file%t_dim(1:2)%i_len /= &
994	tl_mpp%t_dim(1:2)%i_len) )THEN
995
996	CALL logger_error("MPP INIT READ: dimension from file "//&
997	& TRIM(tl_file%c_name)//" and mpp strcuture "//&
998	& TRIM(mpp__init_file%c_name)//"differ ")
999
1000	ELSE
1001
1002	! add processor to mpp strcuture
1003	CALL mpp__add_proc(mpp__init_file, tl_mpp%t_proc(1))
1004
1005	ENDIF
1006	ENDIF
1007
1008	! close file
1009	CALL iom_close(tl_file)
1010
1011	ENDDO
1012	IF( mpp__init_file%i_nproc /= il_nproc )THEN
1013	CALL logger_error("MPP INIT READ: some processors can't be added &
1014	& to mpp structure")
1015	ENDIF
1016
1017	ELSE
1018	mpp__init_file=mpp_copy(tl_mpp)
1019	ENDIF
1020
1021	! mpp type
1022	mpp__init_file%c_type=TRIM(td_file%c_type)
1023
1024	! mpp domain type
1025	CALL mpp_get_dom(mpp__init_file)
1026
1027	! create some attributes for domain decomposition (use with dimg file)
1028	tl_att=att_init( "DOMAIN_number_total", mpp__init_file%i_nproc )
1029	CALL mpp_move_att(mpp__init_file, tl_att)
1030
1031	tl_att=att_init( "DOMAIN_I_position_first", mpp__init_file%t_proc(:)%i_impp )
1032	CALL mpp_move_att(mpp__init_file, tl_att)
1033
1034	tl_att=att_init( "DOMAIN_J_position_first", mpp__init_file%t_proc(:)%i_jmpp )
1035	CALL mpp_move_att(mpp__init_file, tl_att)
1036
1037	tl_att=att_init( "DOMAIN_I_position_last", mpp__init_file%t_proc(:)%i_lci )
1038	CALL mpp_move_att(mpp__init_file, tl_att)
1039
1040	tl_att=att_init( "DOMAIN_J_position_last", mpp__init_file%t_proc(:)%i_lcj )
1041	CALL mpp_move_att(mpp__init_file, tl_att)
1042
1043	tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_file%t_proc(:)%i_ldi )
1044	CALL mpp_move_att(mpp__init_file, tl_att)
1045
1046	tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_file%t_proc(:)%i_ldj )
1047	CALL mpp_move_att(mpp__init_file, tl_att)
1048
1049	tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_file%t_proc(:)%i_lei )
1050	CALL mpp_move_att(mpp__init_file, tl_att)
1051
1052	tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_file%t_proc(:)%i_lej )
1053	CALL mpp_move_att(mpp__init_file, tl_att)
1054
1055	! clean
1056	CALL mpp_clean(tl_mpp)
1057	CALL att_clean(tl_att)
1058
1059	CASE('dimg')
1060	! domain decomposition could be read in one file
1061
1062	tl_file=file_copy(td_file)
1063	! open file
1064	CALL logger_debug("MPP INIT READ: open file "//TRIM(tl_file%c_name))
1065	CALL iom_open(tl_file)
1066
1067	CALL logger_debug("MPP INIT READ: read mpp structure ")
1068	! read mpp structure
1069	mpp__init_file=mpp__init_file_rstdimg(tl_file)
1070
1071	! mpp type
1072	mpp__init_file%c_type=TRIM(td_file%c_type)
1073
1074	! mpp domain type
1075	CALL logger_debug("MPP INIT READ: mpp_get_dom ")
1076	CALL mpp_get_dom(mpp__init_file)
1077
1078	! get processor size
1079	CALL logger_debug("MPP INIT READ: get processor size ")
1080	DO ji=1,mpp__init_file%i_nproc
1081
1082	il_shape(:)=mpp_get_proc_size( mpp__init_file, ji )
1083
1084	tl_dim=dim_init('X',il_shape(1))
1085	CALL file_add_dim(mpp__init_file%t_proc(ji), tl_dim)
1086
1087	tl_dim=dim_init('Y',il_shape(2))
1088	CALL file_add_dim(mpp__init_file%t_proc(ji), tl_dim)
1089
1090	! clean
1091	CALL dim_clean(tl_dim)
1092
1093	ENDDO
1094
1095	! close file
1096	CALL iom_close(tl_file)
1097
1098	CASE DEFAULT
1099	CALL logger_error("MPP INIT READ: invalid type for file "//&
1100	& TRIM(tl_file%c_name))
1101	END SELECT
1102
1103	! east west overlap
1104	IF( PRESENT(id_ew) ) mpp__init_file%i_ew=id_ew
1105	! NEMO periodicity
1106	IF( PRESENT(id_perio) )THEN
1107	mpp__init_file%i_perio= id_perio
1108	SELECT CASE(id_perio)
1109	CASE(3,4)
1110	mpp__init_file%i_pivot=1
1111	CASE(5,6)
1112	mpp__init_file%i_pivot=0
1113	CASE DEFAULT
1114	mpp__init_file%i_pivot=1
1115	END SELECT
1116	ENDIF
1117
1118	IF( PRESENT(id_pivot) ) mpp__init_file%i_pivot= id_pivot
1119
1120	! clean
1121	CALL file_clean(tl_file)
1122
1123	END FUNCTION mpp__init_file
1124	!-------------------------------------------------------------------
1125	!> @brief This function initalise a mpp structure,
1126	!> reading some netcdf files.
1127	!
1128	!> @details
1129	!
1130	!> @author J.Paul
1131	!> - November, 2013 - Initial Version
1132	!> @date July, 2015 - add only use dimension in MPP structure
1133	!>
1134	!> @param[in] td_file file strcuture
1135	!> @return mpp structure
1136	!-------------------------------------------------------------------
1137	TYPE(TMPP) FUNCTION mpp__init_file_cdf( td_file )
1138	IMPLICIT NONE
1139
1140	! Argument
1141	TYPE(TFILE), INTENT(IN) :: td_file
1142
1143	! local variable
1144	INTEGER(i4) :: il_attid ! attribute id
1145
1146	LOGICAL :: ll_exist
1147	LOGICAL :: ll_open
1148
1149	TYPE(TATT) :: tl_att
1150
1151	TYPE(TDIM) :: tl_dim
1152
1153	TYPE(TFILE) :: tl_proc
1154	!----------------------------------------------------------------
1155
1156	CALL logger_trace("MPP INIT READ: netcdf file "//TRIM(td_file%c_name))
1157
1158	INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open )
1159	! ll_open do not work for netcdf file, return always FALSE
1160	IF( ll_exist )THEN
1161
1162	IF( td_file%i_id == 0 )THEN
1163	CALL logger_info(" id "//TRIM(fct_str(td_file%i_id)))
1164	CALL logger_error("MPP INIT READ: netcdf file "//&
1165	& TRIM(td_file%c_name)//" not opened")
1166	ELSE
1167
1168	! get mpp name
1169	mpp__init_file_cdf%c_name=TRIM( file_rename(td_file%c_name) )
1170
1171	! add type
1172	mpp__init_file_cdf%c_type="cdf"
1173
1174	! global domain size
1175	il_attid = 0
1176	IF( ASSOCIATED(td_file%t_att) )THEN
1177	il_attid=att_get_id( td_file%t_att, "DOMAIN_size_global" )
1178	ENDIF
1179	IF( il_attid /= 0 )THEN
1180	tl_dim=dim_init('X',INT(td_file%t_att(il_attid)%d_value(1)))
1181	CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
1182
1183	tl_dim=dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2)))
1184	CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
1185	ELSE ! assume only one file (not mpp)
1186	tl_dim=dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len)
1187	CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
1188
1189	tl_dim=dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len)
1190	CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
1191	ENDIF
1192
1193	IF( td_file%t_dim(3)%l_use )THEN
1194	tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len)
1195	CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
1196	ENDIF
1197
1198	IF( td_file%t_dim(4)%l_use )THEN
1199	tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len)
1200	CALL mpp_add_dim(mpp__init_file_cdf,tl_dim)
1201	ENDIF
1202
1203	! initialise file/processor
1204	tl_proc=file_copy(td_file)
1205
1206	! processor id
1207	il_attid = 0
1208	IF( ASSOCIATED(td_file%t_att) )THEN
1209	il_attid=att_get_id( td_file%t_att, "DOMAIN_number" )
1210	ENDIF
1211	IF( il_attid /= 0 )THEN
1212	tl_proc%i_pid = INT(td_file%t_att(il_attid)%d_value(1))
1213	ELSE
1214	tl_proc%i_pid = 1
1215	ENDIF
1216
1217	! processor dimension
1218	tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:))
1219
1220	! DOMAIN_position_first
1221	il_attid = 0
1222	IF( ASSOCIATED(td_file%t_att) )THEN
1223	il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" )
1224	ENDIF
1225	IF( il_attid /= 0 )THEN
1226	tl_proc%i_impp = INT(td_file%t_att(il_attid)%d_value(1))
1227	tl_proc%i_jmpp = INT(td_file%t_att(il_attid)%d_value(2))
1228	ELSE
1229	tl_proc%i_impp = 1
1230	tl_proc%i_jmpp = 1
1231	ENDIF
1232
1233	! DOMAIN_position_last
1234	il_attid = 0
1235	IF( ASSOCIATED(td_file%t_att) )THEN
1236	il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" )
1237	ENDIF
1238	IF( il_attid /= 0 )THEN
1239	tl_proc%i_lci = INT(td_file%t_att(il_attid)%d_value(1)) + tl_proc%i_impp
1240	tl_proc%i_lcj = INT(td_file%t_att(il_attid)%d_value(2)) + tl_proc%i_jmpp
1241	ELSE
1242	tl_proc%i_lci = mpp__init_file_cdf%t_dim(1)%i_len
1243	tl_proc%i_lcj = mpp__init_file_cdf%t_dim(2)%i_len
1244	ENDIF
1245
1246	! DOMAIN_halo_size_start
1247	il_attid = 0
1248	IF( ASSOCIATED(td_file%t_att) )THEN
1249	il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" )
1250	ENDIF
1251	IF( il_attid /= 0 )THEN
1252	tl_proc%i_ldi = INT(td_file%t_att(il_attid)%d_value(1))
1253	tl_proc%i_ldj = INT(td_file%t_att(il_attid)%d_value(2))
1254	ELSE
1255	tl_proc%i_ldi = 1
1256	tl_proc%i_ldj = 1
1257	ENDIF
1258
1259	! DOMAIN_halo_size_end
1260	il_attid = 0
1261	IF( ASSOCIATED(td_file%t_att) )THEN
1262	il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" )
1263	ENDIF
1264	IF( il_attid /= 0 )THEN
1265	tl_proc%i_lei = INT(td_file%t_att(il_attid)%d_value(1))
1266	tl_proc%i_lej = INT(td_file%t_att(il_attid)%d_value(2))
1267	ELSE
1268	tl_proc%i_lei = mpp__init_file_cdf%t_dim(1)%i_len
1269	tl_proc%i_lej = mpp__init_file_cdf%t_dim(2)%i_len
1270	ENDIF
1271
1272	! add attributes
1273	tl_att=att_init( "DOMAIN_size_global", &
1274	& mpp__init_file_cdf%t_dim(:)%i_len)
1275	CALL file_move_att(tl_proc, tl_att)
1276
1277	tl_att=att_init( "DOMAIN_number", tl_proc%i_pid )
1278	CALL file_move_att(tl_proc, tl_att)
1279
1280	tl_att=att_init( "DOMAIN_position_first", &
1281	& (/tl_proc%i_impp, tl_proc%i_jmpp /) )
1282	CALL file_move_att(tl_proc, tl_att)
1283
1284	tl_att=att_init( "DOMAIN_position_last", &
1285	& (/tl_proc%i_lci, tl_proc%i_lcj /) )
1286	CALL file_move_att(tl_proc, tl_att)
1287
1288	tl_att=att_init( "DOMAIN_halo_size_start", &
1289	& (/tl_proc%i_ldi, tl_proc%i_ldj /) )
1290	CALL file_move_att(tl_proc, tl_att)
1291
1292	tl_att=att_init( "DOMAIN_halo_size_end", &
1293	& (/tl_proc%i_lei, tl_proc%i_lej /) )
1294	CALL file_move_att(tl_proc, tl_att)
1295
1296	! add processor to mpp structure
1297	CALL mpp__add_proc(mpp__init_file_cdf, tl_proc)
1298
1299	! clean
1300	CALL file_clean(tl_proc)
1301	CALL att_clean(tl_att)
1302	ENDIF
1303
1304	ELSE
1305
1306	CALL logger_error("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)//&
1307	& " do not exist")
1308
1309	ENDIF
1310	END FUNCTION mpp__init_file_cdf
1311	!-------------------------------------------------------------------
1312	!> @brief This function initalise a mpp structure,
1313	!> reading one dimg restart file.
1314	!
1315	!> @details
1316	!
1317	!> @author J.Paul
1318	!> - November, 2013- Initial Version
1319	!
1320	!> @param[in] td_file file strcuture
1321	!> @return mpp structure
1322	!-------------------------------------------------------------------
1323	TYPE(TMPP) FUNCTION mpp__init_file_rstdimg( td_file )
1324	IMPLICIT NONE
1325
1326	! Argument
1327	TYPE(TFILE), INTENT(IN) :: td_file
1328
1329	! local variable
1330	INTEGER(i4) :: il_status
1331	INTEGER(i4) :: il_recl ! record length
1332	INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension
1333	INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables
1334	INTEGER(i4) :: il_iglo, il_jglo ! domain global size
1335	INTEGER(i4) :: il_rhd ! record of the header infos
1336	INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition
1337	INTEGER(i4) :: il_area ! domain index
1338
1339	LOGICAL :: ll_exist
1340	LOGICAL :: ll_open
1341
1342	CHARACTER(LEN=lc) :: cl_file
1343
1344	TYPE(TDIM) :: tl_dim ! dimension structure
1345	TYPE(TATT) :: tl_att
1346	TYPE(TFILE) :: tl_proc
1347
1348	! loop indices
1349	INTEGER(i4) :: ji
1350	!----------------------------------------------------------------
1351
1352	INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open)
1353	IF( ll_exist )THEN
1354
1355	IF( .NOT. ll_open )THEN
1356	CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//&
1357	& " not opened")
1358	ELSE
1359
1360	! read first record
1361	READ( td_file%i_id, IOSTAT=il_status, REC=1 )&
1362	& il_recl, &
1363	& il_nx, il_ny, il_nz, &
1364	& il_n0d, il_n1d, il_n2d, il_n3d, &
1365	& il_rhd, &
1366	& il_pni, il_pnj, il_pnij, &
1367	& il_area
1368	CALL fct_err(il_status)
1369	IF( il_status /= 0 )THEN
1370	CALL logger_error("MPP INIT READ: read first line header of "//&
1371	& TRIM(td_file%c_name))
1372	ENDIF
1373
1374	! get mpp name
1375	mpp__init_file_rstdimg%c_name=TRIM( file_rename(td_file%c_name) )
1376
1377	! add type
1378	mpp__init_file_rstdimg%c_type="dimg"
1379
1380	! number of processors to be read
1381	mpp__init_file_rstdimg%i_nproc = il_pnij
1382	mpp__init_file_rstdimg%i_niproc = il_pni
1383	mpp__init_file_rstdimg%i_njproc = il_pnj
1384
1385	IF( ASSOCIATED(mpp__init_file_rstdimg%t_proc) )THEN
1386	CALL file_clean(mpp__init_file_rstdimg%t_proc(:))
1387	DEALLOCATE(mpp__init_file_rstdimg%t_proc)
1388	ENDIF
1389	ALLOCATE( mpp__init_file_rstdimg%t_proc(il_pnij) , stat=il_status )
1390
1391	tl_proc=file_copy(td_file)
1392	! remove dimension from file
1393	CALL dim_clean(tl_proc%t_dim(:))
1394	! initialise file/processors
1395	DO ji=1,mpp__init_file_rstdimg%i_nproc
1396	mpp__init_file_rstdimg%t_proc(ji)=file_copy(tl_proc)
1397	ENDDO
1398
1399	IF( il_status /= 0 )THEN
1400	CALL logger_error("MPP INIT READ: not enough space to read domain &
1401	& decomposition in file "//TRIM(td_file%c_name))
1402	ENDIF
1403
1404	! read first record
1405	READ( td_file%i_id, IOSTAT=il_status, REC=1 )&
1406	& il_recl, &
1407	& il_nx, il_ny, il_nz, &
1408	& il_n0d, il_n1d, il_n2d, il_n3d, &
1409	& il_rhd, &
1410	& il_pni, il_pnj, il_pnij, &
1411	& il_area, &
1412	& il_iglo, il_jglo, &
1413	& mpp__init_file_rstdimg%t_proc(:)%i_lci, &
1414	& mpp__init_file_rstdimg%t_proc(:)%i_lcj, &
1415	& mpp__init_file_rstdimg%t_proc(:)%i_ldi, &
1416	& mpp__init_file_rstdimg%t_proc(:)%i_ldj, &
1417	& mpp__init_file_rstdimg%t_proc(:)%i_lei, &
1418	& mpp__init_file_rstdimg%t_proc(:)%i_lej, &
1419	& mpp__init_file_rstdimg%t_proc(:)%i_impp, &
1420	& mpp__init_file_rstdimg%t_proc(:)%i_jmpp
1421	CALL fct_err(il_status)
1422	IF( il_status /= 0 )THEN
1423	CALL logger_error("MPP INIT READ: read first line of "//&
1424	& TRIM(td_file%c_name))
1425	ENDIF
1426
1427	! global domain size
1428	tl_dim=dim_init('X',il_iglo)
1429	CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim)
1430	tl_dim=dim_init('Y',il_jglo)
1431	CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim)
1432
1433	tl_dim=dim_init('Z',il_nz)
1434	CALL mpp_add_dim(mpp__init_file_rstdimg,tl_dim)
1435
1436	DO ji=1,mpp__init_file_rstdimg%i_nproc
1437	! get file name
1438	cl_file = file_rename(td_file%c_name,ji)
1439	mpp__init_file_rstdimg%t_proc(ji)%c_name = TRIM(cl_file)
1440	! update processor id
1441	mpp__init_file_rstdimg%t_proc(ji)%i_pid=ji
1442
1443	! add attributes
1444	tl_att=att_init( "DOMAIN_number", ji )
1445	CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
1446
1447	tl_att=att_init( "DOMAIN_position_first", &
1448	& (/mpp__init_file_rstdimg%t_proc(ji)%i_impp, &
1449	& mpp__init_file_rstdimg%t_proc(ji)%i_jmpp /) )
1450	CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
1451
1452	tl_att=att_init( "DOMAIN_position_last", &
1453	& (/mpp__init_file_rstdimg%t_proc(ji)%i_lci, &
1454	& mpp__init_file_rstdimg%t_proc(ji)%i_lcj /) )
1455	CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
1456
1457	tl_att=att_init( "DOMAIN_halo_size_start", &
1458	& (/mpp__init_file_rstdimg%t_proc(ji)%i_ldi, &
1459	& mpp__init_file_rstdimg%t_proc(ji)%i_ldj /) )
1460	CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
1461
1462	tl_att=att_init( "DOMAIN_halo_size_end", &
1463	& (/mpp__init_file_rstdimg%t_proc(ji)%i_lei, &
1464	& mpp__init_file_rstdimg%t_proc(ji)%i_lej /) )
1465	CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)
1466	ENDDO
1467
1468	! add type
1469	mpp__init_file_rstdimg%t_proc(:)%c_type="dimg"
1470
1471	! add attributes
1472	tl_att=att_init( "DOMAIN_size_global", &
1473	& mpp__init_file_rstdimg%t_dim(:)%i_len)
1474	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1475
1476	tl_att=att_init( "DOMAIN_number_total", &
1477	& mpp__init_file_rstdimg%i_nproc )
1478	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1479
1480	tl_att=att_init( "DOMAIN_I_number_total", &
1481	& mpp__init_file_rstdimg%i_niproc )
1482	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1483
1484	tl_att=att_init( "DOMAIN_J_number_total", &
1485	& mpp__init_file_rstdimg%i_njproc )
1486	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1487
1488	tl_att=att_init( "DOMAIN_I_position_first", &
1489	& mpp__init_file_rstdimg%t_proc(:)%i_impp )
1490	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1491
1492	tl_att=att_init( "DOMAIN_J_position_first", &
1493	& mpp__init_file_rstdimg%t_proc(:)%i_jmpp )
1494	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1495
1496	tl_att=att_init( "DOMAIN_I_position_last", &
1497	& mpp__init_file_rstdimg%t_proc(:)%i_lci )
1498	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1499
1500	tl_att=att_init( "DOMAIN_J_position_last", &
1501	& mpp__init_file_rstdimg%t_proc(:)%i_lcj )
1502	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1503
1504	tl_att=att_init( "DOMAIN_I_halo_size_start", &
1505	& mpp__init_file_rstdimg%t_proc(:)%i_ldi )
1506	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1507
1508	tl_att=att_init( "DOMAIN_J_halo_size_start", &
1509	& mpp__init_file_rstdimg%t_proc(:)%i_ldj )
1510	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1511
1512	tl_att=att_init( "DOMAIN_I_halo_size_end", &
1513	& mpp__init_file_rstdimg%t_proc(:)%i_lei )
1514	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1515
1516	tl_att=att_init( "DOMAIN_J_halo_size_end", &
1517	& mpp__init_file_rstdimg%t_proc(:)%i_lej )
1518	CALL mpp_move_att(mpp__init_file_rstdimg, tl_att)
1519
1520	! clean
1521	CALL dim_clean(tl_dim)
1522	CALL att_clean(tl_att)
1523	ENDIF
1524
1525	ELSE
1526
1527	CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//&
1528	& " do not exist")
1529
1530	ENDIF
1531
1532	END FUNCTION mpp__init_file_rstdimg
1533	!-------------------------------------------------------------------
1534	!> @brief This function check if variable and mpp structure use same
1535	!> dimension.
1536	!
1537	!> @author J.Paul
1538	!> - Nov, 2013- Initial Version
1539	!
1540	!> @param[in] td_mpp mpp structure
1541	!> @param[in] td_proc processor structure
1542	!> @return dimension of processor and mpp structure agree (or not)
1543	!-------------------------------------------------------------------
1544	LOGICAL FUNCTION mpp__check_proc_dim(td_mpp, td_proc)
1545	IMPLICIT NONE
1546	! Argument
1547	TYPE(TMPP), INTENT(IN) :: td_mpp
1548	TYPE(TFILE), INTENT(IN) :: td_proc
1549
1550	! local variable
1551	INTEGER(i4) :: il_isize !< i-direction maximum sub domain size
1552	INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size
1553
1554	!----------------------------------------------------------------
1555	mpp__check_proc_dim=.TRUE.
1556	! check used dimension
1557	IF( td_mpp%i_niproc /= 0 .AND. td_mpp%i_njproc /= 0 )THEN
1558	! check with maximum size of sub domain
1559	il_isize = ( td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + &
1560	& (td_mpp%i_niproc-1) ) / td_mpp%i_niproc + 2*td_mpp%i_preci
1561	il_jsize = ( td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + &
1562	& (td_mpp%i_njproc-1) ) / td_mpp%i_njproc + 2*td_mpp%i_precj
1563
1564	IF( il_isize < td_proc%i_lci .OR. &
1565	& il_jsize < td_proc%i_lcj )THEN
1566
1567	mpp__check_proc_dim=.FALSE.
1568
1569	CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" )
1570
1571	ENDIF
1572
1573	ELSE
1574	! check with global domain size
1575	IF( td_mpp%t_dim(1)%i_len < td_proc%i_lci .OR. &
1576	& td_mpp%t_dim(2)%i_len < td_proc%i_lcj )THEN
1577
1578	mpp__check_proc_dim=.FALSE.
1579
1580	CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" )
1581
1582	ENDIF
1583	ENDIF
1584
1585	END FUNCTION mpp__check_proc_dim
1586	!-------------------------------------------------------------------
1587	!> @brief
1588	!> This subroutine add variable in all files of mpp structure.
1589	!>
1590	!> @author J.Paul
1591	!> @date November, 2013 - Initial version
1592	!
1593	!> @param[inout] td_mpp mpp strcuture
1594	!> @param[in] td_var variable strcuture
1595	!-------------------------------------------------------------------
1596	SUBROUTINE mpp_add_var( td_mpp, td_var )
1597	IMPLICIT NONE
1598	! Argument
1599	TYPE(TMPP), INTENT(INOUT) :: td_mpp
1600	TYPE(TVAR), INTENT(IN) :: td_var
1601
1602	! local variable
1603	INTEGER(i4) :: il_varid
1604	TYPE(TVAR) :: tl_var
1605
1606	! loop indices
1607	INTEGER(i4) :: ji
1608	!----------------------------------------------------------------
1609	! check if mpp exist
1610	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
1611
1612	CALL logger_error( "MPP ADD VAR: processor decomposition not "//&
1613	& "define for mpp "//TRIM(td_mpp%c_name))
1614
1615	ELSE
1616	! check if variable exist
1617	IF( TRIM(td_var%c_name) == '' .AND. &
1618	& TRIM(td_var%c_stdname) == '' )THEN
1619	CALL logger_error("MPP ADD VAR: variable not define ")
1620	ELSE
1621	! check if variable already in mpp structure
1622	il_varid=0
1623	IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
1624	il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
1625	& td_var%c_name, td_var%c_stdname )
1626	ENDIF
1627
1628	IF( il_varid /= 0 )THEN
1629
1630	DO ji=1,td_mpp%t_proc(1)%i_nvar
1631	CALL logger_debug( " MPP ADD VAR: in mpp structure : &
1632	& variable "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//&
1633	& ", standard name "//&
1634	& TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) )
1635	ENDDO
1636	CALL logger_error( " MPP ADD VAR: variable "//TRIM(td_var%c_name)//&
1637	& ", standard name "//TRIM(td_var%c_stdname)//&
1638	& ", already in mpp "//TRIM(td_mpp%c_name) )
1639
1640	ELSE
1641
1642	CALL logger_info( &
1643	& " MPP ADD VAR: add variable "//TRIM(td_var%c_name)//&
1644	& ", standard name "//TRIM(td_var%c_stdname)//&
1645	& ", in mpp "//TRIM(td_mpp%c_name) )
1646	! check used dimension
1647	IF( mpp__check_dim(td_mpp, td_var) )THEN
1648
1649	! update dimension if need be
1650	DO ji=1,ip_maxdim
1651	IF( td_var%t_dim(ji)%l_use .AND. &
1652	& .NOT. td_mpp%t_dim(ji)%l_use )THEN
1653	CALL mpp_add_dim(td_mpp,td_var%t_dim(ji))
1654	ENDIF
1655	ENDDO
1656
1657	! add variable in each processor
1658	DO ji=1,td_mpp%i_nproc
1659
1660	! split variable on domain decomposition
1661	tl_var=mpp__split_var(td_mpp, td_var, ji)
1662
1663	CALL file_add_var(td_mpp%t_proc(ji), tl_var)
1664
1665	! clean
1666	CALL var_clean(tl_var)
1667	ENDDO
1668
1669	ENDIF
1670	ENDIF
1671	ENDIF
1672	ENDIF
1673
1674	END SUBROUTINE mpp_add_var
1675	!-------------------------------------------------------------------
1676	!> @brief This function extract, from variable structure, part that will
1677	!> be written in processor id_procid.<br/>
1678	!
1679	!> @author J.Paul
1680	!> - November, 2013- Initial Version
1681	!
1682	!> @param[in] td_mpp mpp structure
1683	!> @param[in] td_var variable structure
1684	!> @param[in] id_procid processor id
1685	!> @return variable structure
1686	!-------------------------------------------------------------------
1687	TYPE(TVAR) FUNCTION mpp__split_var(td_mpp, td_var, id_procid)
1688	IMPLICIT NONE
1689	! Argument
1690	TYPE(TMPP), INTENT(IN) :: td_mpp
1691	TYPE(TVAR), INTENT(IN) :: td_var
1692	INTEGER(i4), INTENT(IN) :: id_procid
1693
1694	! local variable
1695	TYPE(TDIM) :: tl_dim
1696
1697	INTEGER(i4), DIMENSION(4) :: il_ind
1698	INTEGER(i4), DIMENSION(2) :: il_size
1699	INTEGER(i4) :: il_i1
1700	INTEGER(i4) :: il_i2
1701	INTEGER(i4) :: il_j1
1702	INTEGER(i4) :: il_j2
1703	!----------------------------------------------------------------
1704
1705	! copy mpp
1706	mpp__split_var=var_copy(td_var)
1707
1708	IF( ASSOCIATED(td_var%d_value) )THEN
1709	! remove value over global domain from pointer
1710	CALL var_del_value( mpp__split_var )
1711
1712	! get processor dimension
1713	il_size(:)=mpp_get_proc_size( td_mpp, id_procid )
1714
1715	! define new dimension in variable structure
1716	IF( td_var%t_dim(1)%l_use )THEN
1717	tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) )
1718	CALL var_move_dim( mpp__split_var, tl_dim )
1719	ENDIF
1720	IF( td_var%t_dim(2)%l_use )THEN
1721	tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) )
1722	CALL var_move_dim( mpp__split_var, tl_dim )
1723	ENDIF
1724
1725	! get processor indices
1726	il_ind(:)=mpp_get_proc_index( td_mpp, id_procid )
1727	il_i1 = il_ind(1)
1728	il_i2 = il_ind(2)
1729	il_j1 = il_ind(3)
1730	il_j2 = il_ind(4)
1731
1732	IF( .NOT. td_var%t_dim(1)%l_use )THEN
1733	il_i1=1
1734	il_i2=1
1735	ENDIF
1736
1737	IF( .NOT. td_var%t_dim(2)%l_use )THEN
1738	il_j1=1
1739	il_j2=1
1740	ENDIF
1741
1742	! add variable value on processor
1743	CALL var_add_value( mpp__split_var, &
1744	& td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) )
1745	ENDIF
1746
1747	END FUNCTION mpp__split_var
1748	!-------------------------------------------------------------------
1749	!> @brief
1750	!> This subroutine delete all variable in mpp strcuture.
1751	!>
1752	!> @author J.Paul
1753	!> @date October, 2014 - Initial version
1754	!>
1755	!> @param[inout] td_mpp mpp strcuture
1756	!-------------------------------------------------------------------
1757	SUBROUTINE mpp__del_var_mpp( td_mpp )
1758	IMPLICIT NONE
1759	! Argument
1760	TYPE(TMPP), INTENT(INOUT) :: td_mpp
1761
1762	! local variable
1763	! loop indices
1764	INTEGER(i4) :: ji
1765	!----------------------------------------------------------------
1766
1767	CALL logger_info( &
1768	& "MPP CLEAN VAR: reset all variable "//&
1769	& "in mpp strcuture "//TRIM(td_mpp%c_name) )
1770
1771	IF( ASSOCIATED(td_mpp%t_proc) )THEN
1772	DO ji=td_mpp%t_proc(1)%i_nvar,1,-1
1773	CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(ji))
1774	ENDDO
1775	ENDIF
1776
1777	END SUBROUTINE mpp__del_var_mpp
1778	!-------------------------------------------------------------------
1779	!> @brief
1780	!> This subroutine delete variable in mpp structure, given variable
1781	!> structure.
1782	!>
1783	!> @author J.Paul
1784	!> @date November, 2013 - Initial version
1785	!
1786	!> @param[inout] td_mpp mpp strcuture
1787	!> @param[in] td_var variable strcuture
1788	!-------------------------------------------------------------------
1789	SUBROUTINE mpp__del_var_str( td_mpp, td_var )
1790	IMPLICIT NONE
1791	! Argument
1792	TYPE(TMPP), INTENT(INOUT) :: td_mpp
1793	TYPE(TVAR), INTENT(IN) :: td_var
1794
1795	! local variable
1796	INTEGER(i4) :: il_varid
1797	CHARACTER(LEN=lc) :: cl_name
1798
1799	! loop indices
1800	INTEGER(i4) :: ji
1801	!----------------------------------------------------------------
1802	! check if mpp exist
1803	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
1804
1805	CALL logger_error( "MPP DEL VAR: domain decomposition not define "//&
1806	& " in mpp strcuture "//TRIM(td_mpp%c_name))
1807
1808	ELSE
1809
1810	! check if variable already in mpp structure
1811	il_varid = 0
1812	IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
1813	il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
1814	& td_var%c_name, td_var%c_stdname )
1815	ENDIF
1816	IF( il_varid == 0 )THEN
1817	CALL logger_error( &
1818	& "MPP DEL VAR: no variable "//TRIM(td_var%c_name)//&
1819	& ", in mpp structure "//TRIM(td_mpp%c_name) )
1820
1821	DO ji=1,td_mpp%t_proc(1)%i_nvar
1822	CALL logger_debug( "MPP DEL VAR: in mpp structure : &
1823	& variable : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//&
1824	& ", standard name "//&
1825	& TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) )
1826	ENDDO
1827
1828	ELSE
1829
1830	cl_name=TRIM(td_var%c_name)
1831	DO ji=1,td_mpp%i_nproc
1832	CALL file_del_var(td_mpp%t_proc(ji), TRIM(cl_name))
1833	ENDDO
1834
1835	ENDIF
1836
1837	ENDIF
1838	END SUBROUTINE mpp__del_var_str
1839	!-------------------------------------------------------------------
1840	!> @brief
1841	!> This subroutine delete variable in mpp structure, given variable name.
1842	!>
1843	!> @author J.Paul
1844	!> @date November, 2013 - Initial version
1845	!> @date February, 2015 - define local variable structure to avoid mistake
1846	!> with pointer
1847	!
1848	!> @param[inout] td_mpp mpp strcuture
1849	!> @param[in] cd_name variable name
1850	!-------------------------------------------------------------------
1851	SUBROUTINE mpp__del_var_name( td_mpp, cd_name )
1852	IMPLICIT NONE
1853	! Argument
1854	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
1855	CHARACTER(LEN=*), INTENT(IN ) :: cd_name
1856
1857	! local variable
1858	INTEGER(i4) :: il_varid
1859	TYPE(TVAR) :: tl_var
1860	!----------------------------------------------------------------
1861	! check if mpp exist
1862	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
1863
1864	CALL logger_error( "MPP DEL VAR: domain decomposition not define "//&
1865	& " in mpp strcuture "//TRIM(td_mpp%c_name))
1866
1867	ELSE
1868
1869	IF( td_mpp%t_proc(1)%i_nvar == 0 )THEN
1870	CALL logger_debug( "MPP DEL VAR NAME: no variable associated to mpp &
1871	& structure "//TRIM(td_mpp%c_name) )
1872	ELSE
1873
1874	! get the variable id, in file variable structure
1875	il_varid=0
1876	IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
1877	il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
1878	& cd_name )
1879	ENDIF
1880
1881	IF( il_varid == 0 )THEN
1882
1883	CALL logger_warn( &
1884	& "MPP DEL VAR : there is no variable with name "//&
1885	& "or standard name "//TRIM(ADJUSTL(cd_name))//&
1886	& " in mpp structure "//TRIM(td_mpp%c_name))
1887
1888	ELSE
1889
1890	tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid))
1891	CALL mpp_del_var(td_mpp, tl_var)
1892
1893	ENDIF
1894	ENDIF
1895
1896	ENDIF
1897	END SUBROUTINE mpp__del_var_name
1898	!-------------------------------------------------------------------
1899	!> @brief
1900	!> This subroutine overwrite variable in mpp structure.
1901	!>
1902	!> @author J.Paul
1903	!> @date November, 2013 - Initial version
1904	!
1905	!> @param[inout] td_mpp mpp strcuture
1906	!> @param[in] td_var variable structure
1907	!-------------------------------------------------------------------
1908	SUBROUTINE mpp_move_var( td_mpp, td_var )
1909	IMPLICIT NONE
1910	! Argument
1911	TYPE(TMPP), INTENT(INOUT) :: td_mpp
1912	TYPE(TVAR), INTENT(IN) :: td_var
1913
1914	!local variable
1915	TYPE(TVAR) :: tl_var
1916	!----------------------------------------------------------------
1917	! copy variable
1918	tl_var=var_copy(td_var)
1919
1920	! remove processor
1921	CALL mpp_del_var(td_mpp, tl_var)
1922
1923	! add processor
1924	CALL mpp_add_var(td_mpp, tl_var)
1925
1926	! clean
1927	CALL var_clean(tl_var)
1928
1929	END SUBROUTINE mpp_move_var
1930	!> @endcode
1931	!-------------------------------------------------------------------
1932	!> @brief
1933	!> This subroutine add processor to mpp structure.
1934	!>
1935	!> @author J.Paul
1936	!> @date November, 2013 - Initial version
1937	!
1938	!> @param[inout] td_mpp mpp strcuture
1939	!> @param[in] td_proc processor strcuture
1940	!
1941	!> @todo
1942	!> - check proc type
1943	!-------------------------------------------------------------------
1944	SUBROUTINE mpp__add_proc( td_mpp, td_proc )
1945	IMPLICIT NONE
1946	! Argument
1947	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
1948	TYPE(TFILE), INTENT(IN) :: td_proc
1949
1950	! local variable
1951	INTEGER(i4) :: il_status
1952	INTEGER(i4) :: il_procid
1953	INTEGER(i4) , DIMENSION(1) :: il_ind
1954
1955	TYPE(TFILE) , DIMENSION(:), ALLOCATABLE :: tl_proc
1956
1957	CHARACTER(LEN=lc) :: cl_name
1958	!----------------------------------------------------------------
1959
1960	! check file name
1961	cl_name=TRIM( file_rename(td_proc%c_name) )
1962	IF( TRIM(cl_name) /= TRIM(td_mpp%c_name) )THEN
1963	CALL logger_warn("MPP ADD PROC: processor name do not match mpp name")
1964	ENDIF
1965
1966	il_procid=0
1967	IF( ASSOCIATED(td_mpp%t_proc) )THEN
1968	! check if processor already in mpp structure
1969	il_ind(:)=MINLOC( td_mpp%t_proc(:)%i_pid, &
1970	mask=(td_mpp%t_proc(:)%i_pid==td_proc%i_pid) )
1971	il_procid=il_ind(1)
1972	ENDIF
1973
1974	IF( il_procid /= 0 )THEN
1975
1976	CALL logger_error( &
1977	& "MPP ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//&
1978	& ", already in mpp structure " )
1979
1980	ELSE
1981
1982	CALL logger_trace("MPP ADD PROC: add processor "//&
1983	& TRIM(fct_str(td_mpp%i_nproc+1))//" in mpp structure")
1984
1985	IF( td_mpp%i_nproc > 0 )THEN
1986	!
1987	il_ind(:)=MAXLOC( td_mpp%t_proc(:)%i_pid, &
1988	mask=(td_mpp%t_proc(:)%i_pid < td_proc%i_pid) )
1989	il_procid=il_ind(1)
1990
1991	! already other processor in mpp structure
1992	ALLOCATE( tl_proc(td_mpp%i_nproc), stat=il_status )
1993	IF(il_status /= 0 )THEN
1994
1995	CALL logger_error( "MPP ADD PROC: not enough space to put processor &
1996	& in mpp structure")
1997
1998	ELSE
1999	! save temporary mpp structure
2000	tl_proc(:)=file_copy(td_mpp%t_proc(:))
2001
2002	CALL file_clean( td_mpp%t_proc(:) )
2003	DEALLOCATE(td_mpp%t_proc)
2004	ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status)
2005	IF(il_status /= 0 )THEN
2006
2007	CALL logger_error( "MPP ADD PROC: not enough space to put "//&
2008	& "processor in mpp structure ")
2009
2010	ENDIF
2011
2012	! copy processor in mpp before
2013	! processor with lower id than new processor
2014	td_mpp%t_proc( 1:il_procid ) = file_copy(tl_proc( 1:il_procid ))
2015
2016	! processor with greater id than new processor
2017	td_mpp%t_proc( il_procid+1 : td_mpp%i_nproc+1 ) = &
2018	& file_copy(tl_proc( il_procid : td_mpp%i_nproc ))
2019
2020	! clean
2021	CALL file_clean(tl_proc(:))
2022	DEALLOCATE(tl_proc)
2023	ENDIF
2024
2025	ELSE
2026	! no processor in mpp structure
2027	IF( ASSOCIATED(td_mpp%t_proc) )THEN
2028	CALL file_clean(td_mpp%t_proc(:))
2029	DEALLOCATE(td_mpp%t_proc)
2030	ENDIF
2031	ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status )
2032	IF(il_status /= 0 )THEN
2033
2034	CALL logger_error( "MPP ADD PROC: not enough space to put "//&
2035	& "processor in mpp structure " )
2036
2037	ENDIF
2038	ENDIF
2039
2040	! check dimension
2041	IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc%t_dim(1:2)%i_len) )THEN
2042	CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//&
2043	& " dimension differ. ")
2044	CALL logger_debug("MPP ADD PROC: mpp dimension ("//&
2045	& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
2046	& TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" )
2047	CALL logger_debug("MPP ADD PROC: processor dimension ("//&
2048	& TRIM(fct_str(td_proc%t_dim(1)%i_len))//","//&
2049	& TRIM(fct_str(td_proc%t_dim(2)%i_len))//")" )
2050	ELSE
2051	td_mpp%i_nproc=td_mpp%i_nproc+1
2052
2053	! add new processor
2054	td_mpp%t_proc(td_mpp%i_nproc)=file_copy(td_proc)
2055	ENDIF
2056
2057	ENDIF
2058	END SUBROUTINE mpp__add_proc
2059	!-------------------------------------------------------------------
2060	!> @brief
2061	!> This subroutine delete processor in mpp structure, given processor id.
2062	!>
2063	!> @author J.Paul
2064	!> @date November, 2013 - Initial version
2065	!>
2066	!> @param[inout] td_mpp mpp strcuture
2067	!> @param[in] id_procid processor id
2068	!-------------------------------------------------------------------
2069	SUBROUTINE mpp__del_proc_id( td_mpp, id_procid )
2070	IMPLICIT NONE
2071	! Argument
2072	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2073	INTEGER(i4), INTENT(IN) :: id_procid
2074
2075	! local variable
2076	INTEGER(i4) :: il_status
2077	INTEGER(i4) :: il_procid
2078	INTEGER(i4), DIMENSION(1) :: il_ind
2079	TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc
2080
2081	! loop indices
2082	!----------------------------------------------------------------
2083
2084	il_ind(:)=MINLOC(td_mpp%t_proc(:)%i_pid,td_mpp%t_proc(:)%i_pid==id_procid)
2085	il_procid=il_ind(1)
2086	IF( il_procid == 0 )THEN
2087	CALL logger_error("MPP DEL PROC: no processor "//&
2088	& TRIM(fct_str(id_procid))//&
2089	& " associated to mpp structure")
2090	ELSE
2091	CALL logger_trace("DEL PROC: remove processor "//&
2092	& TRIM(fct_str(id_procid)))
2093
2094	IF( td_mpp%i_nproc > 1 )THEN
2095	ALLOCATE( tl_proc(td_mpp%i_nproc-1), stat=il_status )
2096	IF(il_status /= 0 )THEN
2097	CALL logger_error( "MPP DEL PROC: not enough space to put &
2098	& processor in temporary mpp structure")
2099
2100	ELSE
2101
2102	! save temporary processor's mpp structure
2103	IF( il_procid > 1 )THEN
2104	tl_proc(1:il_procid-1)=file_copy(td_mpp%t_proc(1:il_procid-1))
2105	ENDIF
2106
2107	IF( il_procid < td_mpp%i_nproc )THEN
2108	tl_proc(il_procid:)=file_copy(td_mpp%t_proc(il_procid+1:))
2109	ENDIF
2110
2111	! new number of processor in mpp
2112	td_mpp%i_nproc=td_mpp%i_nproc-1
2113
2114	CALL file_clean( td_mpp%t_proc(:) )
2115	DEALLOCATE(td_mpp%t_proc)
2116	ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc), stat=il_status )
2117	IF(il_status /= 0 )THEN
2118
2119	CALL logger_error( "MPP DEL PROC: not enough space &
2120	& to put processors in mpp structure " )
2121
2122	ELSE
2123
2124	! copy processor in mpp before
2125	td_mpp%t_proc(:)=file_copy(tl_proc(:))
2126
2127	! update processor id
2128	td_mpp%t_proc( il_procid : td_mpp%i_nproc )%i_pid = &
2129	& td_mpp%t_proc( il_procid : td_mpp%i_nproc )%i_pid - 1
2130
2131	ENDIF
2132	ENDIF
2133	! clean
2134	CALL file_clean( tl_proc(:) )
2135	DEALLOCATE(tl_proc)
2136	ELSE
2137	CALL file_clean( td_mpp%t_proc(:) )
2138	DEALLOCATE(td_mpp%t_proc)
2139
2140	! new number of processor in mpp
2141	td_mpp%i_nproc=td_mpp%i_nproc-1
2142	ENDIF
2143	ENDIF
2144	END SUBROUTINE mpp__del_proc_id
2145	!-------------------------------------------------------------------
2146	!> @brief
2147	!> This subroutine delete processor in mpp structure, given processor
2148	!> structure.
2149	!>
2150	!> @author J.Paul
2151	!> @date November, 2013 - Initial version
2152	!
2153	!> @param[inout] td_mpp : mpp strcuture
2154	!> @param[in] td_proc : file/processor structure
2155	!-------------------------------------------------------------------
2156	SUBROUTINE mpp__del_proc_str( td_mpp, td_proc )
2157	IMPLICIT NONE
2158	! Argument
2159	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2160	TYPE(TFILE), INTENT(IN) :: td_proc
2161	!----------------------------------------------------------------
2162
2163	IF( td_proc%i_pid >= 0 )THEN
2164	CALL mpp__del_proc( td_mpp, td_proc%i_pid )
2165	ELSE
2166	CALL logger_error("MPP DEL PROC: processor not defined")
2167	ENDIF
2168
2169	END SUBROUTINE mpp__del_proc_str
2170	!-------------------------------------------------------------------
2171	!> @brief
2172	!> This subroutine overwrite processor in mpp structure.
2173	!>
2174	!> @detail
2175	!
2176	!> @author J.Paul
2177	!> @date Nov, 2013 - Initial version
2178	!
2179	!> @param[inout] td_mpp mpp strcuture
2180	!> @param[in] id_procid processor id
2181	!-------------------------------------------------------------------
2182	SUBROUTINE mpp__move_proc( td_mpp, td_proc )
2183	IMPLICIT NONE
2184	! Argument
2185	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2186	TYPE(TFILE), INTENT(IN) :: td_proc
2187	!----------------------------------------------------------------
2188
2189	! remove processor
2190	CALL mpp__del_proc(td_mpp, td_proc)
2191
2192	! add processor
2193	CALL mpp__add_proc(td_mpp, td_proc)
2194
2195	END SUBROUTINE mpp__move_proc
2196	!-------------------------------------------------------------------
2197	!> @brief This subroutine add a dimension structure in a mpp
2198	!> structure.
2199	!> Do not overwrite, if dimension already in mpp structure.
2200	!>
2201	!> @author J.Paul
2202	!> - November, 2013- Initial Version
2203	!> @date July, 2015 - rewrite the same as way var_add_dim
2204	!>
2205	!> @param[inout] td_mpp mpp structure
2206	!> @param[in] td_dim dimension structure
2207	!-------------------------------------------------------------------
2208	SUBROUTINE mpp_add_dim(td_mpp, td_dim)
2209	IMPLICIT NONE
2210	! Argument
2211	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2212	TYPE(TDIM), INTENT(IN) :: td_dim
2213
2214	! local variable
2215	INTEGER(i4) :: il_ind
2216
2217	! loop indices
2218	!----------------------------------------------------------------
2219	IF( td_mpp%i_ndim <= ip_maxdim )THEN
2220
2221	! check if dimension already used in mpp structure
2222	il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname))
2223	IF( il_ind == 0 )THEN
2224	CALL logger_warn( &
2225	& " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//&
2226	& ", short name "//TRIM(td_dim%c_sname)//&
2227	& ", will not be added in mpp "//TRIM(td_mpp%c_name) )
2228	ELSEIF( td_mpp%t_dim(il_ind)%l_use )THEN
2229	CALL logger_error( &
2230	& " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//&
2231	& ", short name "//TRIM(td_dim%c_sname)//&
2232	& ", already used in mpp "//TRIM(td_mpp%c_name) )
2233	ELSE
2234
2235	! back to disorder dimension array
2236	CALL dim_disorder(td_mpp%t_dim(:))
2237
2238	! add new dimension
2239	td_mpp%t_dim(td_mpp%i_ndim+1)=dim_copy(td_dim)
2240
2241	! update number of attribute
2242	td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use)
2243
2244	ENDIF
2245	! reorder dimension to ('x','y','z','t')
2246	CALL dim_reorder(td_mpp%t_dim(:))
2247
2248	ELSE
2249	CALL logger_error( &
2250	& "MPP ADD DIM: too much dimension in mpp "//&
2251	& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
2252	ENDIF
2253
2254	END SUBROUTINE mpp_add_dim
2255	!-------------------------------------------------------------------
2256	!> @brief This subroutine delete a dimension structure in a mpp
2257	!> structure.<br/>
2258	!>
2259	!> @author J.Paul
2260	!> - November, 2013- Initial Version
2261	!> @date July, 2015 - rewrite the same as way var_del_dim
2262	!>
2263	!> @param[inout] td_mpp mpp structure
2264	!> @param[in] td_dim dimension structure
2265	!-------------------------------------------------------------------
2266	SUBROUTINE mpp_del_dim(td_mpp, td_dim)
2267	IMPLICIT NONE
2268	! Argument
2269	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2270	TYPE(TDIM), INTENT(IN) :: td_dim
2271
2272	! local variable
2273	INTEGER(i4) :: il_ind
2274	TYPE(TDIM) :: tl_dim
2275
2276	! loop indices
2277	!----------------------------------------------------------------
2278
2279
2280	IF( td_mpp%i_ndim <= ip_maxdim )THEN
2281
2282	CALL logger_trace( &
2283	& " MPP DEL DIM: delete dimension "//TRIM(td_dim%c_name)//&
2284	& ", short name "//TRIM(td_dim%c_sname)//&
2285	& ", in mpp "//TRIM(td_mpp%c_name) )
2286
2287	! check if dimension already in variable structure
2288	il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname))
2289
2290	! replace dimension by empty one
2291	td_mpp%t_dim(il_ind)=dim_copy(tl_dim)
2292
2293	! update number of dimension
2294	td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use)
2295
2296	! reorder dimension to ('x','y','z','t')
2297	CALL dim_reorder(td_mpp%t_dim)
2298
2299	ELSE
2300	CALL logger_error( &
2301	& " MPP DEL DIM: too much dimension in mpp "//&
2302	& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
2303	ENDIF
2304
2305	END SUBROUTINE mpp_del_dim
2306	!-------------------------------------------------------------------
2307	!> @brief This subroutine move a dimension structure
2308	!> in mpp structure.
2309	!> @warning dimension order may have changed
2310	!>
2311	!> @author J.Paul
2312	!> - November, 2013- Initial Version
2313	!>
2314	!> @param[inout] td_mpp mpp structure
2315	!> @param[in] td_dim dimension structure
2316	!-------------------------------------------------------------------
2317	SUBROUTINE mpp_move_dim(td_mpp, td_dim)
2318	IMPLICIT NONE
2319	! Argument
2320	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2321	TYPE(TDIM), INTENT(IN) :: td_dim
2322
2323	! local variable
2324	INTEGER(i4) :: il_ind
2325	INTEGER(i4) :: il_dimid
2326	!----------------------------------------------------------------
2327	IF( td_mpp%i_ndim <= ip_maxdim )THEN
2328
2329	! check if dimension already in mpp structure
2330	il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
2331	IF( il_ind /= 0 )THEN
2332
2333	il_dimid=td_mpp%t_dim(il_ind)%i_id
2334	! replace dimension
2335	td_mpp%t_dim(il_ind)=dim_copy(td_dim)
2336	td_mpp%t_dim(il_ind)%i_id=il_dimid
2337	td_mpp%t_dim(il_ind)%l_use=.TRUE.
2338
2339	ELSE
2340	CALL mpp_add_dim(td_mpp, td_dim)
2341	ENDIF
2342
2343	ELSE
2344	CALL logger_error( &
2345	& "MPP MOVE DIM: too much dimension in mpp "//&
2346	& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
2347	ENDIF
2348	END SUBROUTINE mpp_move_dim
2349	!-------------------------------------------------------------------
2350	!> @brief
2351	!> This subroutine add global attribute to mpp structure.
2352	!>
2353	!> @author J.Paul
2354	!> @date November, 2013 - Initial version
2355	!>
2356	!> @param[inout] td_mpp mpp strcuture
2357	!> @param[in] td_att attribute strcuture
2358	!-------------------------------------------------------------------
2359	SUBROUTINE mpp_add_att( td_mpp, td_att )
2360	IMPLICIT NONE
2361	! Argument
2362	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2363	TYPE(TATT), INTENT(IN) :: td_att
2364
2365	! local variable
2366	INTEGER(i4) :: il_attid
2367
2368	! loop indices
2369	INTEGER(i4) :: ji
2370	!----------------------------------------------------------------
2371	! check if mpp exist
2372	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
2373
2374	CALL logger_error( "MPP ADD ATT: domain decomposition not define "//&
2375	& "for mpp "//TRIM(td_mpp%c_name))
2376
2377	ELSE
2378	! check if variable exist
2379	IF( TRIM(td_att%c_name) == '' )THEN
2380	CALL logger_error("MPP ADD ATT: attribute not define ")
2381	ELSE
2382	! check if attribute already in mpp structure
2383	il_attid=0
2384	IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
2385	il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), &
2386	& td_att%c_name )
2387	ENDIF
2388	IF( il_attid /= 0 )THEN
2389
2390	CALL logger_error( " MPP ADD ATT: attribute "//&
2391	& TRIM(td_att%c_name)//&
2392	& ", already in mpp "//TRIM(td_mpp%c_name) )
2393
2394	DO ji=1,td_mpp%t_proc(1)%i_natt
2395	CALL logger_debug( " MPP ADD ATT: in mpp structure : &
2396	& attribute "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) )
2397	ENDDO
2398
2399	ELSE
2400
2401	CALL logger_info( &
2402	& " MPP ADD ATT: add attribute "//TRIM(td_att%c_name)//&
2403	& ", in mpp "//TRIM(td_mpp%c_name) )
2404
2405	! add attribute in each processor
2406	DO ji=1,td_mpp%i_nproc
2407
2408	CALL file_add_att(td_mpp%t_proc(ji), td_att)
2409
2410	ENDDO
2411
2412	ENDIF
2413	ENDIF
2414	ENDIF
2415
2416	END SUBROUTINE mpp_add_att
2417	!-------------------------------------------------------------------
2418	!> @brief
2419	!> This subroutine delete attribute in mpp structure, given attribute
2420	!> structure.
2421	!>
2422	!> @author J.Paul
2423	!> @date November, 2013 - Initial version
2424	!>
2425	!> @param[inout] td_mpp mpp strcuture
2426	!> @param[in] td_att attribute strcuture
2427	!-------------------------------------------------------------------
2428	SUBROUTINE mpp__del_att_str( td_mpp, td_att )
2429	IMPLICIT NONE
2430	! Argument
2431	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2432	TYPE(TATT), INTENT(IN) :: td_att
2433
2434	! local variable
2435	INTEGER(i4) :: il_attid
2436	CHARACTER(LEN=lc) :: cl_name
2437
2438	! loop indices
2439	INTEGER(i4) :: ji
2440	!----------------------------------------------------------------
2441	! check if mpp exist
2442	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
2443
2444	CALL logger_warn( "MPP DEL VAR: domain decomposition not define "//&
2445	& " in mpp strcuture "//TRIM(td_mpp%c_name))
2446
2447	ELSE
2448
2449	! check if attribute already in mpp structure
2450	il_attid=0
2451	IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
2452	il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), &
2453	& td_att%c_name )
2454	ENDIF
2455	IF( il_attid == 0 )THEN
2456	CALL logger_warn( &
2457	& "MPP DEL VAR: no attribute "//TRIM(td_att%c_name)//&
2458	& ", in mpp structure "//TRIM(td_mpp%c_name) )
2459
2460	IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
2461	DO ji=1,td_mpp%t_proc(1)%i_natt
2462	CALL logger_debug( "MPP DEL ATT: in mpp structure : &
2463	& attribute : "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) )
2464	ENDDO
2465	ENDIF
2466
2467	ELSE
2468
2469	cl_name=TRIM(td_att%c_name)
2470	CALL logger_debug( "MPP DEL ATT: delete in mpp structure : &
2471	& attribute : "//TRIM(cl_name) )
2472	DO ji=1,td_mpp%i_nproc
2473	CALL file_del_att(td_mpp%t_proc(ji), TRIM(cl_name))
2474	ENDDO
2475
2476	ENDIF
2477
2478	ENDIF
2479	END SUBROUTINE mpp__del_att_str
2480	!-------------------------------------------------------------------
2481	!> @brief
2482	!> This subroutine delete attribute in mpp structure, given attribute name.
2483	!>
2484	!> @detail
2485	!
2486	!> @author J.Paul
2487	!> @date November, 2013 - Initial version
2488	!> @date February, 2015 - define local attribute structure to avoid mistake
2489	!> with pointer
2490	!
2491	!> @param[inout] td_mpp mpp strcuture
2492	!> @param[in] cd_name attribute name
2493	!-------------------------------------------------------------------
2494	SUBROUTINE mpp__del_att_name( td_mpp, cd_name )
2495	IMPLICIT NONE
2496	! Argument
2497	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
2498	CHARACTER(LEN=*) , INTENT(IN ) :: cd_name
2499
2500	! local variable
2501	INTEGER(i4) :: il_attid
2502	TYPE(TATT) :: tl_att
2503	!----------------------------------------------------------------
2504	! check if mpp exist
2505	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
2506
2507	CALL logger_warn( "MPP DEL ATT: domain decomposition not define "//&
2508	& " in mpp strcuture "//TRIM(td_mpp%c_name))
2509
2510	ELSE
2511
2512	IF( td_mpp%t_proc(1)%i_natt == 0 )THEN
2513	CALL logger_debug( "MPP DEL ATT NAME: no attribute associated to mpp &
2514	& structure "//TRIM(td_mpp%c_name) )
2515	ELSE
2516
2517	! get the attribute id, in file variable structure
2518	il_attid=0
2519	IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
2520	il_attid=att_get_id( td_mpp%t_proc(1)%t_att(:), &
2521	& cd_name )
2522	ENDIF
2523
2524	IF( il_attid == 0 )THEN
2525
2526	CALL logger_debug( &
2527	& "MPP DEL ATT : there is no attribute with "//&
2528	& "name "//TRIM(cd_name)//" in mpp structure "//&
2529	& TRIM(td_mpp%c_name))
2530
2531	ELSE
2532
2533	tl_att=att_copy(td_mpp%t_proc(1)%t_att(il_attid))
2534	CALL mpp_del_att(td_mpp, tl_att)
2535
2536	ENDIF
2537	ENDIF
2538
2539	ENDIF
2540	END SUBROUTINE mpp__del_att_name
2541	!-------------------------------------------------------------------
2542	!> @brief
2543	!> This subroutine overwrite attribute in mpp structure.
2544	!>
2545	!> @author J.Paul
2546	!> @date November, 2013 - Initial version
2547	!
2548	!> @param[inout] td_mpp mpp strcuture
2549	!> @param[in] td_att attribute structure
2550	!-------------------------------------------------------------------
2551	SUBROUTINE mpp_move_att( td_mpp, td_att )
2552	IMPLICIT NONE
2553	! Argument
2554	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2555	TYPE(TATT), INTENT(IN) :: td_att
2556
2557	!local variable
2558	TYPE(TATT) :: tl_att
2559	!----------------------------------------------------------------
2560	! copy variable
2561	tl_att=att_copy(td_att)
2562
2563	! remove processor
2564	CALL mpp_del_att(td_mpp, tl_att)
2565
2566	! add processor
2567	CALL mpp_add_att(td_mpp, tl_att)
2568
2569	! clean
2570	CALL att_clean(tl_att)
2571
2572	END SUBROUTINE mpp_move_att
2573	!-------------------------------------------------------------------
2574	!> @brief
2575	!> This subroutine compute domain decomposition for niproc and njproc
2576	!> processors following I and J.
2577	!>
2578	!> @detail
2579	!> To do so, it need to know :
2580	!> - global domain dimension
2581	!> - overlap region length
2582	!> - number of processors following I and J
2583	!
2584	!> @author J.Paul
2585	!> @date November, 2013 - Initial version
2586	!
2587	!> @param[inout] td_mpp mpp strcuture
2588	!-------------------------------------------------------------------
2589	SUBROUTINE mpp__compute( td_mpp )
2590	IMPLICIT NONE
2591	! Argument
2592	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2593
2594	! local variable
2595	INTEGER(i4) :: il_isize !< i-direction maximum sub domain size
2596	INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size
2597	INTEGER(i4) :: il_resti !<
2598	INTEGER(i4) :: il_restj !<
2599	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlci
2600	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlcj
2601	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_impp
2602	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_jmpp
2603
2604	CHARACTER(LEN=lc) :: cl_file
2605	TYPE(TFILE) :: tl_proc
2606	TYPE(TATT) :: tl_att
2607
2608	! loop indices
2609	INTEGER(i4) :: ji
2610	INTEGER(i4) :: jj
2611	INTEGER(i4) :: jk
2612	!----------------------------------------------------------------
2613
2614	! intialise
2615	td_mpp%i_nproc=0
2616
2617	CALL logger_trace( "MPP COMPUTE: compute domain decomposition with "//&
2618	& TRIM(fct_str(td_mpp%i_niproc))//" x "//&
2619	& TRIM(fct_str(td_mpp%i_njproc))//" processors")
2620	! maximum size of sub domain
2621	il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (td_mpp%i_niproc-1))/ &
2622	& td_mpp%i_niproc) + 2*td_mpp%i_preci
2623	il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (td_mpp%i_njproc-1))/ &
2624	& td_mpp%i_njproc) + 2*td_mpp%i_precj
2625
2626	il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_mpp%i_niproc)
2627	il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_mpp%i_njproc)
2628	IF( il_resti == 0 ) il_resti = td_mpp%i_niproc
2629	IF( il_restj == 0 ) il_restj = td_mpp%i_njproc
2630
2631	! compute dimension of each sub domain
2632	ALLOCATE( il_nlci(td_mpp%i_niproc,td_mpp%i_njproc) )
2633	ALLOCATE( il_nlcj(td_mpp%i_niproc,td_mpp%i_njproc) )
2634
2635	il_nlci( 1 : il_resti , : ) = il_isize
2636	il_nlci( il_resti+1 : td_mpp%i_niproc, : ) = il_isize-1
2637
2638	il_nlcj( : , 1 : il_restj ) = il_jsize
2639	il_nlcj( : , il_restj+1 : td_mpp%i_njproc) = il_jsize-1
2640
2641	! compute first index of each sub domain
2642	ALLOCATE( il_impp(td_mpp%i_niproc,td_mpp%i_njproc) )
2643	ALLOCATE( il_jmpp(td_mpp%i_niproc,td_mpp%i_njproc) )
2644
2645	il_impp(:,:)=1
2646	il_jmpp(:,:)=1
2647
2648	DO jj=1,td_mpp%i_njproc
2649	DO ji=2,td_mpp%i_niproc
2650	il_impp(ji,jj)=il_impp(ji-1,jj)+il_nlci(ji-1,jj)-2*td_mpp%i_preci
2651	ENDDO
2652	ENDDO
2653
2654	DO jj=2,td_mpp%i_njproc
2655	DO ji=1,td_mpp%i_niproc
2656	il_jmpp(ji,jj)=il_jmpp(ji,jj-1)+il_nlcj(ji,jj-1)-2*td_mpp%i_precj
2657	ENDDO
2658	ENDDO
2659
2660	DO jj=1,td_mpp%i_njproc
2661	DO ji=1,td_mpp%i_niproc
2662
2663	jk=ji+(jj-1)*td_mpp%i_niproc
2664
2665	! get processor file name
2666	cl_file=file_rename(td_mpp%c_name,jk)
2667	! initialise file structure
2668	tl_proc=file_init(cl_file,td_mpp%c_type)
2669
2670	! procesor id
2671	tl_proc%i_pid=jk
2672
2673	tl_att=att_init("DOMAIN_number",tl_proc%i_pid)
2674	CALL file_add_att(tl_proc, tl_att)
2675
2676	! processor indices
2677	tl_proc%i_iind=ji
2678	tl_proc%i_jind=jj
2679
2680	! fill processor dimension and first indices
2681	tl_proc%i_impp = il_impp(ji,jj)
2682	tl_proc%i_jmpp = il_jmpp(ji,jj)
2683
2684	tl_att=att_init( "DOMAIN_poistion_first", &
2685	& (/tl_proc%i_impp, tl_proc%i_jmpp/) )
2686	CALL file_add_att(tl_proc, tl_att)
2687
2688	tl_proc%i_lci = il_nlci(ji,jj)
2689	tl_proc%i_lcj = il_nlcj(ji,jj)
2690
2691	tl_att=att_init( "DOMAIN_poistion_last", &
2692	& (/tl_proc%i_lci, tl_proc%i_lcj/) )
2693	CALL file_add_att(tl_proc, tl_att)
2694
2695	! compute first and last indoor indices
2696
2697	! west boundary
2698	IF( ji == 1 )THEN
2699	tl_proc%i_ldi = 1
2700	tl_proc%l_ctr = .TRUE.
2701	ELSE
2702	tl_proc%i_ldi = 1 + td_mpp%i_preci
2703	ENDIF
2704
2705	! south boundary
2706	IF( jj == 1 )THEN
2707	tl_proc%i_ldj = 1
2708	tl_proc%l_ctr = .TRUE.
2709	ELSE
2710	tl_proc%i_ldj = 1 + td_mpp%i_precj
2711	ENDIF
2712
2713	! east boundary
2714	IF( ji == td_mpp%i_niproc )THEN
2715	tl_proc%i_lei = il_nlci(ji,jj)
2716	tl_proc%l_ctr = .TRUE.
2717	ELSE
2718	tl_proc%i_lei = il_nlci(ji,jj) - td_mpp%i_preci
2719	ENDIF
2720
2721	! north boundary
2722	IF( jj == td_mpp%i_njproc )THEN
2723	tl_proc%i_lej = il_nlcj(ji,jj)
2724	tl_proc%l_ctr = .TRUE.
2725	ELSE
2726	tl_proc%i_lej = il_nlcj(ji,jj) - td_mpp%i_precj
2727	ENDIF
2728
2729	tl_att=att_init( "DOMAIN_halo_size_start", &
2730	& (/tl_proc%i_ldi, tl_proc%i_ldj/) )
2731	CALL file_add_att(tl_proc, tl_att)
2732	tl_att=att_init( "DOMAIN_halo_size_end", &
2733	& (/tl_proc%i_ldi, tl_proc%i_ldj/) )
2734	CALL file_add_att(tl_proc, tl_att)
2735
2736	! add processor to mpp structure
2737	CALL mpp__add_proc(td_mpp, tl_proc)
2738
2739	! clean
2740	CALL att_clean(tl_att)
2741	CALL file_clean(tl_proc)
2742
2743	ENDDO
2744	ENDDO
2745
2746	DEALLOCATE( il_impp, il_jmpp )
2747	DEALLOCATE( il_nlci, il_nlcj )
2748
2749	END SUBROUTINE mpp__compute
2750	!-------------------------------------------------------------------
2751	!> @brief
2752	!> This subroutine remove land processor from domain decomposition.
2753	!>
2754	!> @author J.Paul
2755	!> @date November, 2013 - Initial version
2756	!>
2757	!> @param[inout] td_mpp mpp strcuture
2758	!> @param[in] id_mask sub domain mask (sea=1, land=0)
2759	!-------------------------------------------------------------------
2760	SUBROUTINE mpp__del_land( td_mpp, id_mask )
2761	IMPLICIT NONE
2762	! Argument
2763	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2764	INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
2765
2766	! loop indices
2767	INTEGER(i4) :: jk
2768	!----------------------------------------------------------------
2769
2770	IF( ASSOCIATED(td_mpp%t_proc) )THEN
2771	jk=1
2772	DO WHILE( jk <= td_mpp%i_nproc )
2773	IF( mpp__land_proc(td_mpp, jk, id_mask(:,:)) )THEN
2774	CALL mpp__del_proc(td_mpp, jk)
2775	ELSE
2776	jk=jk+1
2777	ENDIF
2778	ENDDO
2779	ELSE
2780	CALL logger_error("MPP DEL LAND: domain decomposition not define.")
2781	ENDIF
2782
2783	END SUBROUTINE mpp__del_land
2784	!-------------------------------------------------------------------
2785	!> @brief
2786	!> This subroutine optimize the number of sub domain to be used, given mask.
2787	!> @details
2788	!> Actually it get the domain decomposition with the most land
2789	!> processor removed.
2790	!
2791	!> @author J.Paul
2792	!> @date November, 2013 - Initial version
2793	!
2794	!> @param[inout] td_mpp mpp strcuture
2795	!> @param[in] id_mask sub domain mask (sea=1, land=0)
2796	!-------------------------------------------------------------------
2797	SUBROUTINE mpp__optimiz( td_mpp, id_mask )
2798	IMPLICIT NONE
2799	! Argument
2800	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2801	INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
2802
2803	! local variable
2804	TYPE(TMPP) :: tl_mpp
2805	INTEGER(i4) :: il_maxproc
2806
2807	TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc
2808	! loop indices
2809	INTEGER(i4) :: ji
2810	INTEGER(i4) :: jj
2811	!----------------------------------------------------------------
2812
2813	CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition")
2814	tl_mpp=mpp_copy(td_mpp)
2815
2816	! save maximum number of processor to be used
2817	il_maxproc=td_mpp%i_nproc
2818	!
2819	td_mpp%i_nproc=0
2820	DO ji=1,il_maxproc
2821	DO jj=1,il_maxproc
2822
2823	! clean mpp processor
2824	IF( ASSOCIATED(tl_mpp%t_proc) )THEN
2825	CALL file_clean(tl_mpp%t_proc(:))
2826	DEALLOCATE(tl_mpp%t_proc)
2827	ENDIF
2828
2829	! compute domain decomposition
2830	tl_mpp%i_niproc=ji
2831	tl_mpp%i_njproc=jj
2832
2833	CALL mpp__compute( tl_mpp )
2834
2835	! remove land sub domain
2836	CALL mpp__del_land( tl_mpp, id_mask )
2837
2838	CALL logger_info("MPP OPTIMIZ: number of processor "//&
2839	& TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//&
2840	& TRIM(fct_str(tl_mpp%i_nproc)) )
2841	IF( tl_mpp%i_nproc > td_mpp%i_nproc .AND. &
2842	& tl_mpp%i_nproc <= il_maxproc )THEN
2843	! save optimiz decomposition
2844
2845	CALL logger_info("MPP OPTIMIZ:save this decomposition "//&
2846	& TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//&
2847	& TRIM(fct_str(tl_mpp%i_nproc)) )
2848
2849	! clean mpp
2850	CALL mpp_clean(td_mpp)
2851
2852	! save processor array
2853	ALLOCATE( tl_proc(tl_mpp%i_nproc) )
2854	tl_proc(:)=file_copy(tl_mpp%t_proc(:))
2855
2856	! remove pointer on processor array
2857	CALL file_clean(tl_mpp%t_proc(:))
2858	DEALLOCATE(tl_mpp%t_proc)
2859
2860	! save data except processor array
2861	td_mpp=mpp_copy(tl_mpp)
2862
2863	! save processor array
2864	ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc) )
2865	td_mpp%t_proc(:)=file_copy(tl_proc(:))
2866
2867	! clean
2868	CALL file_clean( tl_proc(:) )
2869	DEALLOCATE(tl_proc)
2870
2871	ENDIF
2872
2873	ENDDO
2874	ENDDO
2875
2876	! clean
2877	CALL mpp_clean(tl_mpp)
2878
2879	END SUBROUTINE mpp__optimiz
2880	!-------------------------------------------------------------------
2881	!> @brief
2882	!> This function check if processor is a land processor.
2883	!>
2884	!> @author J.Paul
2885	!> @date November, 2013 - Initial version
2886	!>
2887	!> @param[in] td_mpp mpp strcuture
2888	!> @param[in] id_proc processor id
2889	!> @param[in] id_mask sub domain mask (sea=1, land=0)
2890	!-------------------------------------------------------------------
2891	LOGICAL FUNCTION mpp__land_proc( td_mpp , id_proc, id_mask )
2892	IMPLICIT NONE
2893	! Argument
2894	TYPE(TMPP), INTENT(IN) :: td_mpp
2895	INTEGER(i4), INTENT(IN) :: id_proc
2896	INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
2897
2898	! local variable
2899	INTEGER(i4), DIMENSION(2) :: il_shape
2900	!----------------------------------------------------------------
2901
2902	CALL logger_trace("MPP LAND PROC: check processor "//TRIM(fct_str(id_proc))//&
2903	& " of mpp "//TRIM(td_mpp%c_name) )
2904	mpp__land_proc=.FALSE.
2905	IF( ASSOCIATED(td_mpp%t_proc) )THEN
2906
2907	il_shape(:)=SHAPE(id_mask)
2908	IF( il_shape(1) /= td_mpp%t_dim(1)%i_len .OR. &
2909	& il_shape(2) /= td_mpp%t_dim(2)%i_len )THEN
2910	CALL logger_debug("MPP LAND PROC: mask size ("//&
2911	& TRIM(fct_str(il_shape(1)))//","//&
2912	& TRIM(fct_str(il_shape(2)))//")")
2913	CALL logger_debug("MPP LAND PROC: domain size ("//&
2914	& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
2915	& TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")")
2916	CALL logger_error("MPP LAND PROC: mask and domain size differ")
2917	ELSE
2918	IF( ALL(id_mask( td_mpp%t_proc(id_proc)%i_impp + &
2919	& td_mpp%t_proc(id_proc)%i_ldi - 1 : &
2920	& td_mpp%t_proc(id_proc)%i_impp + &
2921	& td_mpp%t_proc(id_proc)%i_lei - 1, &
2922	& td_mpp%t_proc(id_proc)%i_jmpp + &
2923	& td_mpp%t_proc(id_proc)%i_ldj - 1 : &
2924	& td_mpp%t_proc(id_proc)%i_jmpp + &
2925	& td_mpp%t_proc(id_proc)%i_lej - 1) &
2926	& /= 1 ) )THEN
2927	! land domain
2928	CALL logger_info("MPP LAND PROC: processor "//TRIM(fct_str(id_proc))//&
2929	& " is land processor")
2930	mpp__land_proc=.TRUE.
2931	ENDIF
2932	ENDIF
2933
2934	ELSE
2935	CALL logger_error("MPP LAND PROC: domain decomposition not define.")
2936	ENDIF
2937
2938	END FUNCTION mpp__land_proc
2939	!-------------------------------------------------------------------
2940	!> @brief
2941	!> This subroutine clean mpp strcuture.
2942	!>
2943	!> @author J.Paul
2944	!> @date November, 2013 - Initial version
2945	!>
2946	!> @param[inout] td_mpp mpp strcuture
2947	!-------------------------------------------------------------------
2948	SUBROUTINE mpp__clean_unit( td_mpp )
2949	IMPLICIT NONE
2950	! Argument
2951	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2952
2953	! local variable
2954	TYPE(TMPP) :: tl_mpp ! empty mpp structure
2955
2956	! loop indices
2957	!----------------------------------------------------------------
2958
2959	CALL logger_info( &
2960	& "MPP CLEAN: reset mpp "//TRIM(td_mpp%c_name) )
2961
2962	! del dimension
2963	IF( td_mpp%i_ndim /= 0 )THEN
2964	CALL dim_clean( td_mpp%t_dim(:) )
2965	ENDIF
2966
2967	IF( ASSOCIATED(td_mpp%t_proc) )THEN
2968	! clean array of file processor
2969	CALL file_clean( td_mpp%t_proc(:) )
2970	DEALLOCATE(td_mpp%t_proc)
2971	ENDIF
2972
2973	! replace by empty structure
2974	td_mpp=mpp_copy(tl_mpp)
2975
2976	END SUBROUTINE mpp__clean_unit
2977	!-------------------------------------------------------------------
2978	!> @brief
2979	!> This subroutine clean mpp strcuture.
2980	!>
2981	!> @author J.Paul
2982	!> @date November, 2013 - Initial version
2983	!>
2984	!> @param[inout] td_mpp mpp strcuture
2985	!-------------------------------------------------------------------
2986	SUBROUTINE mpp__clean_arr( td_mpp )
2987	IMPLICIT NONE
2988	! Argument
2989	TYPE(TMPP), DIMENSION(:), INTENT(INOUT) :: td_mpp
2990
2991	! local variable
2992	! loop indices
2993	INTEGER(i4) :: ji
2994	!----------------------------------------------------------------
2995
2996	DO ji=SIZE(td_mpp(:)),1,-1
2997	CALL mpp_clean(td_mpp(ji))
2998	ENDDO
2999
3000	END SUBROUTINE mpp__clean_arr
3001	!-------------------------------------------------------------------
3002	!> @brief
3003	!> This subroutine get sub domains which cover "zoom domain".
3004	!>
3005	!> @author J.Paul
3006	!> @date November, 2013 - Initial version
3007	!>
3008	!> @param[inout] td_mpp mpp strcuture
3009	!> @param[in] id_imin i-direction lower indice
3010	!> @param[in] id_imax i-direction upper indice
3011	!> @param[in] id_jmin j-direction lower indice
3012	!> @param[in] id_jmax j-direction upper indice
3013	!-------------------------------------------------------------------
3014	SUBROUTINE mpp__get_use_unit( td_mpp, id_imin, id_imax, &
3015	& id_jmin, id_jmax )
3016	IMPLICIT NONE
3017	! Argument
3018	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
3019	INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin
3020	INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax
3021	INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin
3022	INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax
3023
3024	! local variable
3025	LOGICAL :: ll_iuse
3026	LOGICAL :: ll_juse
3027
3028	INTEGER(i4) :: il_imin
3029	INTEGER(i4) :: il_imax
3030	INTEGER(i4) :: il_jmin
3031	INTEGER(i4) :: il_jmax
3032
3033	! loop indices
3034	INTEGER(i4) :: jk
3035	!----------------------------------------------------------------
3036	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3037
3038	il_imin=1
3039	il_imax=td_mpp%t_dim(1)%i_len
3040	IF( PRESENT(id_imin) ) il_imin=id_imin
3041	IF( PRESENT(id_imax) ) il_imax=id_imax
3042	il_jmin=1
3043	il_jmax=td_mpp%t_dim(2)%i_len
3044	IF( PRESENT(id_jmin) ) il_jmin=id_jmin
3045	IF( PRESENT(id_jmax) ) il_jmax=id_jmax
3046
3047	! check domain
3048	IF( il_imin < 1 .OR. il_imin > td_mpp%t_dim(1)%i_len .OR. &
3049	& il_imax < 1 .OR. il_imax > td_mpp%t_dim(1)%i_len .OR. &
3050	& il_jmin < 1 .OR. il_jmin > td_mpp%t_dim(2)%i_len .OR. &
3051	& il_jmax < 1 .OR. il_jmax > td_mpp%t_dim(2)%i_len )THEN
3052	CALL logger_debug("MPP GET USE: mpp gloabl size "//&
3053	& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
3054	& TRIM(fct_str(td_mpp%t_dim(2)%i_len)))
3055	CALL logger_debug("MPP GET USE: i-indices "//&
3056	& TRIM(fct_str(il_imin))//","//TRIM(fct_str(il_imax)))
3057	CALL logger_debug("MPP GET USE: j-indices "//&
3058	& TRIM(fct_str(il_jmin))//","//TRIM(fct_str(il_jmax)))
3059	CALL logger_error("MPP GET USE: invalid indices ")
3060	ELSE
3061	td_mpp%t_proc(:)%l_use=.FALSE.
3062	DO jk=1,td_mpp%i_nproc
3063
3064	! check i-direction
3065	ll_iuse=.FALSE.
3066	IF( il_imin < il_imax )THEN
3067
3068	! not overlap east west boundary
3069	IF( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
3070	& il_imin .AND. &
3071	& td_mpp%t_proc(jk)%i_impp < il_imax )THEN
3072	ll_iuse=.TRUE.
3073	ENDIF
3074
3075	ELSEIF( il_imin == il_imax )THEN
3076
3077	! east west cyclic
3078	ll_iuse=.TRUE.
3079
3080	ELSE ! il_imin > id_imax
3081
3082	! overlap east west boundary
3083	IF( ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
3084	& il_imin ) &
3085	& .OR. &
3086	& ( td_mpp%t_proc(jk)%i_impp < il_imax) )THEN
3087	ll_iuse=.TRUE.
3088	ENDIF
3089
3090	ENDIF
3091
3092	! check j-direction
3093	ll_juse=.FALSE.
3094	IF( il_jmin < il_jmax )THEN
3095
3096	! not overlap north fold
3097	IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
3098	& il_jmin .AND. &
3099	& td_mpp%t_proc(jk)%i_jmpp < il_jmax )THEN
3100	ll_juse=.TRUE.
3101	ENDIF
3102
3103	ELSE ! id_jmin >= id_jmax
3104
3105	IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
3106	& il_jmin )THEN
3107	ll_juse=.TRUE.
3108	ENDIF
3109
3110	ENDIF
3111
3112	IF( ll_iuse .AND. ll_juse ) td_mpp%t_proc(jk)%l_use=.TRUE.
3113
3114	ENDDO
3115	ENDIF
3116
3117	ELSE
3118	CALL logger_error("MPP GET USE: mpp decomposition not define.")
3119	ENDIF
3120
3121	END SUBROUTINE mpp__get_use_unit
3122	!-------------------------------------------------------------------
3123	!> @brief
3124	!> This subroutine get sub domains which form global domain border.
3125	!>
3126	!> @author J.Paul
3127	!> @date November, 2013
3128	!>
3129	!> @param[inout] td_mpp mpp strcuture
3130	!-------------------------------------------------------------------
3131	SUBROUTINE mpp_get_contour( td_mpp )
3132	IMPLICIT NONE
3133	! Argument
3134	TYPE(TMPP), INTENT(INOUT) :: td_mpp
3135
3136	! loop indices
3137	INTEGER(i4) :: jk
3138	!----------------------------------------------------------------
3139
3140	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3141
3142	td_mpp%t_proc(:)%l_use = .FALSE.
3143	DO jk=1,td_mpp%i_nproc
3144	IF( td_mpp%t_proc(jk)%i_ldi == 1 .OR. &
3145	& td_mpp%t_proc(jk)%i_ldj == 1 .OR. &
3146	& td_mpp%t_proc(jk)%i_lei == td_mpp%t_proc(jk)%i_lci .OR. &
3147	& td_mpp%t_proc(jk)%i_lej == td_mpp%t_proc(jk)%i_lcj )THEN
3148
3149	td_mpp%t_proc(jk)%l_use = .TRUE.
3150
3151	ENDIF
3152	ENDDO
3153
3154	ELSE
3155	CALL logger_error("MPP GET CONTOUR: domain decomposition not define.")
3156	ENDIF
3157
3158	END SUBROUTINE mpp_get_contour
3159	!-------------------------------------------------------------------
3160	!> @brief
3161	!> This function return processor indices, without overlap boundary,
3162	!> given processor id.
3163	!>
3164	!> @author J.Paul
3165	!> @date November, 2013
3166	!>
3167	!> @param[in] td_mpp mpp strcuture
3168	!> @param[in] id_procid processor id
3169	!> @return array of index (/ i1, i2, j1, j2 /)
3170	!-------------------------------------------------------------------
3171	FUNCTION mpp_get_proc_index( td_mpp, id_procid )
3172	IMPLICIT NONE
3173
3174	! Argument
3175	TYPE(TMPP) , INTENT(IN) :: td_mpp
3176	INTEGER(i4), INTENT(IN) :: id_procid
3177
3178	! function
3179	INTEGER(i4), DIMENSION(4) :: mpp_get_proc_index
3180
3181	! local variable
3182	INTEGER(i4) :: il_i1, il_i2
3183	INTEGER(i4) :: il_j1, il_j2
3184	!----------------------------------------------------------------
3185
3186	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3187
3188	IF( TRIM(td_mpp%c_dom) == '' )THEN
3189	CALL logger_fatal("MPP GET PROC INDEX: decomposition type unknown. "//&
3190	& "you should ahve run mpp_get_dom before.")
3191	ENDIF
3192
3193	SELECT CASE(TRIM(td_mpp%c_dom))
3194	CASE('full')
3195	il_i1 = 1 ; il_i2 = td_mpp%t_dim(1)%i_len
3196	il_j1 = 1 ; il_j2 = td_mpp%t_dim(2)%i_len
3197	CASE('overlap')
3198	il_i1 = td_mpp%t_proc(id_procid)%i_impp
3199	il_j1 = td_mpp%t_proc(id_procid)%i_jmpp
3200
3201	il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1
3202	il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1
3203	CASE('nooverlap')
3204	il_i1 = td_mpp%t_proc(id_procid)%i_impp + &
3205	& td_mpp%t_proc(id_procid)%i_ldi - 1
3206	il_j1 = td_mpp%t_proc(id_procid)%i_jmpp + &
3207	& td_mpp%t_proc(id_procid)%i_ldj - 1
3208
3209	il_i2 = td_mpp%t_proc(id_procid)%i_impp + &
3210	& td_mpp%t_proc(id_procid)%i_lei - 1
3211	il_j2 = td_mpp%t_proc(id_procid)%i_jmpp + &
3212	& td_mpp%t_proc(id_procid)%i_lej - 1
3213	CASE DEFAULT
3214	CALL logger_error("MPP GET PROC INDEX: invalid decomposition type.")
3215	END SELECT
3216
3217	mpp_get_proc_index(:)=(/il_i1, il_i2, il_j1, il_j2/)
3218
3219	ELSE
3220	CALL logger_error("MPP GET PROC INDEX: domain decomposition not define.")
3221	ENDIF
3222
3223	END FUNCTION mpp_get_proc_index
3224	!-------------------------------------------------------------------
3225	!> @brief
3226	!> This function return processor domain size, depending of domain
3227	!> decompisition type, given sub domain id.
3228	!
3229	!> @author J.Paul
3230	!> @date November, 2013
3231	!
3232	!> @param[in] td_mpp mpp strcuture
3233	!> @param[in] id_procid sub domain id
3234	!> @return array of index (/ isize, jsize /)
3235	!-------------------------------------------------------------------
3236	FUNCTION mpp_get_proc_size( td_mpp, id_procid )
3237	IMPLICIT NONE
3238
3239	! Argument
3240	TYPE(TMPP), INTENT(IN) :: td_mpp
3241	INTEGER(i4), INTENT(IN) :: id_procid
3242
3243	! function
3244	INTEGER(i4), DIMENSION(2) :: mpp_get_proc_size
3245
3246	! local variable
3247	INTEGER(i4) :: il_isize
3248	INTEGER(i4) :: il_jsize
3249	!----------------------------------------------------------------
3250
3251	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3252
3253	IF( TRIM(td_mpp%c_dom) == '' )THEN
3254	CALL logger_fatal("MPP GET PROC SIZE: decomposition type unknown. "//&
3255	& "you should ahve run mpp_get_dom before.")
3256	ENDIF
3257
3258	SELECT CASE(TRIM(td_mpp%c_dom))
3259	CASE('full')
3260
3261	il_isize = td_mpp%t_dim(1)%i_len
3262	il_jsize = td_mpp%t_dim(2)%i_len
3263
3264	CASE('overlap')
3265
3266	il_isize = td_mpp%t_proc(id_procid)%i_lci
3267	il_jsize = td_mpp%t_proc(id_procid)%i_lcj
3268
3269	CASE('nooverlap')
3270	il_isize = td_mpp%t_proc(id_procid)%i_lei - &
3271	& td_mpp%t_proc(id_procid)%i_ldi + 1
3272	il_jsize = td_mpp%t_proc(id_procid)%i_lej - &
3273	& td_mpp%t_proc(id_procid)%i_ldj + 1
3274	CASE DEFAULT
3275	CALL logger_error("MPP GET PROC SIZE: invalid decomposition type : "//&
3276	& TRIM(td_mpp%c_dom) )
3277	END SELECT
3278
3279	mpp_get_proc_size(:)=(/il_isize, il_jsize/)
3280
3281	ELSE
3282	CALL logger_error("MPP GET PROC SIZE: domain decomposition not define.")
3283	ENDIF
3284
3285	END FUNCTION mpp_get_proc_size
3286	!-------------------------------------------------------------------
3287	!> @brief
3288	!> This subroutine determine domain decomposition type.
3289	!> (full, overlap, noverlap)
3290	!>
3291	!> @author J.Paul
3292	!> @date November, 2013
3293	!>
3294	!> @param[inout] td_mpp mpp strcuture
3295	!-------------------------------------------------------------------
3296	SUBROUTINE mpp_get_dom( td_mpp )
3297	IMPLICIT NONE
3298	! Argument
3299	TYPE(TMPP), INTENT(INOUT) :: td_mpp
3300
3301	! local variable
3302	INTEGER(i4) :: il_isize
3303	INTEGER(i4) :: il_jsize
3304	!----------------------------------------------------------------
3305
3306	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3307
3308	IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_niproc == 0 )THEN
3309	CALL logger_info("MPP GET DOM: use indoor indices to get domain "//&
3310	& "decomposition type.")
3311	IF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
3312	& td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1) .AND. &
3313	& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
3314	& td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1) )THEN
3315
3316	td_mpp%c_dom='nooverlap'
3317
3318	ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
3319	& td_mpp%t_proc(1)%i_lci ) .AND. &
3320	& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
3321	& td_mpp%t_proc(1)%i_lcj ) )THEN
3322
3323	td_mpp%c_dom='overlap'
3324
3325	ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
3326	& td_mpp%t_dim(1)%i_len ) .AND. &
3327	& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
3328	& td_mpp%t_dim(2)%i_len ) )THEN
3329
3330	td_mpp%c_dom='full'
3331
3332	ELSE
3333
3334	CALL logger_error("MPP GET DOM: should have been an impossible case")
3335
3336	il_isize=td_mpp%t_proc(1)%t_dim(1)%i_len
3337	il_jsize=td_mpp%t_proc(1)%t_dim(2)%i_len
3338	CALL logger_debug("MPP GET DOM: proc size "//&
3339	& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
3340
3341	il_isize=td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1
3342	il_jsize=td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1
3343	CALL logger_debug("MPP GET DOM: no overlap size "//&
3344	& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
3345
3346	il_isize=td_mpp%t_proc(1)%i_lci
3347	il_jsize=td_mpp%t_proc(1)%i_lcj
3348	CALL logger_debug("MPP GET DOM: overlap size "//&
3349	& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
3350
3351	il_isize=td_mpp%t_dim(1)%i_len
3352	il_jsize=td_mpp%t_dim(2)%i_len
3353	CALL logger_debug("MPP GET DOM: full size "//&
3354	& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
3355
3356	ENDIF
3357
3358	ELSE
3359
3360	CALL logger_info("MPP GET DOM: use number of processors following "//&
3361	& "I and J to get domain decomposition type.")
3362	IF( td_mpp%i_niproc*td_mpp%i_njproc==td_mpp%i_nproc )THEN
3363	IF( td_mpp%i_nproc == 1 )THEN
3364	td_mpp%c_dom='full'
3365	ENDIF
3366	td_mpp%c_dom='nooverlap'
3367	ELSE
3368	td_mpp%c_dom='overlap'
3369	ENDIF
3370
3371	ENDIF
3372
3373	ELSE
3374	CALL logger_error("MPP GET DOM: domain decomposition not define.")
3375	ENDIF
3376
3377	END SUBROUTINE mpp_get_dom
3378	!-------------------------------------------------------------------
3379	!> @brief This function check if variable and mpp structure use same
3380	!> dimension.
3381	!>
3382	!> @details
3383	!>
3384	!> @author J.Paul
3385	!> - November, 2013- Initial Version
3386	!>
3387	!> @param[in] td_mpp mpp structure
3388	!> @param[in] td_var variable structure
3389	!> @return dimension of variable and mpp structure agree (or not)
3390	!-------------------------------------------------------------------
3391	LOGICAL FUNCTION mpp__check_var_dim(td_mpp, td_var)
3392	IMPLICIT NONE
3393	! Argument
3394	TYPE(TMPP), INTENT(IN) :: td_mpp
3395	TYPE(TVAR), INTENT(IN) :: td_var
3396
3397	! local variable
3398
3399	! loop indices
3400	INTEGER(i4) :: ji
3401	!----------------------------------------------------------------
3402	mpp__check_var_dim=.TRUE.
3403	! check used dimension
3404	IF( ANY( td_var%t_dim(:)%l_use .AND. &
3405	& td_var%t_dim(:)%i_len /= td_mpp%t_dim(:)%i_len) )THEN
3406
3407	mpp__check_var_dim=.FALSE.
3408
3409	CALL logger_debug( &
3410	& " mpp dimension: "//TRIM(fct_str(td_mpp%i_ndim))//&
3411	& " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) )
3412	DO ji = 1, ip_maxdim
3413	CALL logger_debug( &
3414	& "MPP CHECK DIM: for dimension "//&
3415	& TRIM(td_mpp%t_dim(ji)%c_name)//&
3416	& ", mpp length: "//&
3417	& TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//&
3418	& ", variable length: "//&
3419	& TRIM(fct_str(td_var%t_dim(ji)%i_len))//&
3420	& ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use)))
3421	ENDDO
3422
3423	CALL logger_error( &
3424	& "MPP CHECK DIM: variable and mpp dimension differ"//&
3425	& " for variable "//TRIM(td_var%c_name)//&
3426	& " and mpp "//TRIM(td_mpp%c_name))
3427
3428	ENDIF
3429
3430	END FUNCTION mpp__check_var_dim
3431	!-------------------------------------------------------------------
3432	!> @brief This function return the mpp id, in a array of mpp
3433	!> structure, given mpp base name.
3434	!
3435	!> @author J.Paul
3436	!> - November, 2013- Initial Version
3437	!
3438	!> @param[in] td_file array of file structure
3439	!> @param[in] cd_name file name
3440	!> @return file id in array of file structure (0 if not found)
3441	!-------------------------------------------------------------------
3442	INTEGER(i4) FUNCTION mpp_get_index(td_mpp, cd_name)
3443	IMPLICIT NONE
3444	! Argument
3445	TYPE(TMPP) , DIMENSION(:), INTENT(IN) :: td_mpp
3446	CHARACTER(LEN=*), INTENT(IN) :: cd_name
3447
3448	! local variable
3449	CHARACTER(LEN=lc) :: cl_name
3450	INTEGER(i4) :: il_size
3451
3452	! loop indices
3453	INTEGER(i4) :: ji
3454	!----------------------------------------------------------------
3455	mpp_get_index=0
3456	il_size=SIZE(td_mpp(:))
3457
3458	cl_name=TRIM( file_rename(cd_name) )
3459
3460	! check if mpp is in array of mpp structure
3461	DO ji=1,il_size
3462	! look for file name
3463	IF( TRIM(fct_lower(td_mpp(ji)%c_name)) == TRIM(fct_lower(cd_name)) )THEN
3464
3465	mpp_get_index=ji
3466	EXIT
3467
3468	ENDIF
3469	ENDDO
3470
3471	END FUNCTION mpp_get_index
3472	!-------------------------------------------------------------------
3473	!> @brief This function recombine variable splitted mpp structure.
3474	!
3475	!> @author J.Paul
3476	!> - Ocotber, 2014- Initial Version
3477	!
3478	!> @param[in] td_mpp mpp file structure
3479	!> @param[in] cd_name variable name
3480	!> @return variable strucutre
3481	!-------------------------------------------------------------------
3482	TYPE(TVAR) FUNCTION mpp_recombine_var(td_mpp, cd_name)
3483	IMPLICIT NONE
3484	! Argument
3485	TYPE(TMPP) , INTENT(IN) :: td_mpp
3486	CHARACTER(LEN=*), INTENT(IN) :: cd_name
3487
3488	! local variable
3489	INTEGER(i4) :: il_varid
3490	INTEGER(i4) :: il_status
3491	INTEGER(i4) :: il_i1p
3492	INTEGER(i4) :: il_i2p
3493	INTEGER(i4) :: il_j1p
3494	INTEGER(i4) :: il_j2p
3495	INTEGER(i4), DIMENSION(4) :: il_ind
3496
3497	INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
3498	INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt
3499
3500	TYPE(TVAR) :: tl_tmp
3501	TYPE(TVAR) :: tl_var
3502
3503	! loop indices
3504	INTEGER(i4) :: ji
3505	INTEGER(i4) :: jk
3506	!----------------------------------------------------------------
3507
3508	il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
3509	IF( il_varid /= 0 )THEN
3510
3511	tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid))
3512	! Allocate space to hold variable value in structure
3513	IF( ASSOCIATED(tl_var%d_value) )THEN
3514	DEALLOCATE(tl_var%d_value)
3515	ENDIF
3516	!
3517	DO ji=1,ip_maxdim
3518	IF( tl_var%t_dim(ji)%l_use )THEN
3519	tl_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len
3520	ENDIF
3521	ENDDO
3522
3523	ALLOCATE(tl_var%d_value( tl_var%t_dim(1)%i_len, &
3524	& tl_var%t_dim(2)%i_len, &
3525	& tl_var%t_dim(3)%i_len, &
3526	& tl_var%t_dim(4)%i_len),&
3527	& stat=il_status)
3528	IF(il_status /= 0 )THEN
3529
3530	CALL logger_error( &
3531	& " MPP RECOMBINE VAR: not enough space to put variable "//&
3532	& TRIM(tl_var%c_name)//" in variable structure")
3533
3534	ENDIF
3535
3536	! FillValue by default
3537	tl_var%d_value(:,:,:,:)=tl_var%d_fill
3538
3539	! read processor
3540	DO jk=1,td_mpp%i_nproc
3541	IF( td_mpp%t_proc(jk)%l_use )THEN
3542	! get processor indices
3543	il_ind(:)=mpp_get_proc_index( td_mpp, jk )
3544	il_i1p = il_ind(1)
3545	il_i2p = il_ind(2)
3546	il_j1p = il_ind(3)
3547	il_j2p = il_ind(4)
3548
3549	il_strt(:)=(/ 1,1,1,1 /)
3550
3551	il_cnt(:)=(/ il_i2p-il_i1p+1, &
3552	& il_j2p-il_j1p+1, &
3553	& tl_var%t_dim(3)%i_len, &
3554	& tl_var%t_dim(4)%i_len /)
3555
3556	tl_tmp=iom_read_var( td_mpp%t_proc(jk), tl_var%c_name,&
3557	& il_strt(:), il_cnt(:) )
3558
3559	! replace value in output variable structure
3560	tl_var%d_value( il_i1p : il_i2p, &
3561	& il_j1p : il_j2p, &
3562	& :,:) = tl_tmp%d_value(:,:,:,:)
3563
3564	! clean
3565	CALL var_clean(tl_tmp)
3566
3567	ENDIF
3568	ENDDO
3569
3570	mpp_recombine_var=var_copy(tl_var)
3571
3572	! clean
3573	CALL var_clean(tl_var)
3574
3575	ELSE
3576
3577	CALL logger_error( &
3578	& " MPP RECOMBINE VAR: there is no variable with "//&
3579	& "name or standard name"//TRIM(cd_name)//&
3580	& " in mpp file "//TRIM(td_mpp%c_name))
3581	ENDIF
3582	END FUNCTION mpp_recombine_var
3583	END MODULE mpp
3584

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

Download in other formats: