Context Navigation

mpp.f90 @ 13369

Last change on this file since 13369 was 13369, checked in by jpaul, 4 years ago
update: cf changelog inside documentation
File size: 153.5 KB

Line
1	!----------------------------------------------------------------------
2	! NEMO system team, System and Interface for oceanic RElocable Nesting
3	!----------------------------------------------------------------------
4	!
5	! DESCRIPTION:
6	!> @brief
7	!> This module manage massively parallel processing.
8	!>
9	!> @details
10	!> define type TMPP:<br/>
11	!> @code
12	!> TYPE(TMPP) :: tl_mpp
13	!> @endcode
14	!>
15	!> to initialise a mpp structure:<br/>
16	!> @code
17	!> tl_mpp=mpp_init( cd_file, id_mask,
18	!> [id_niproc,] [id_njproc,] [id_nproc,]
19	!> [id_preci,] [id_precj,]
20	!> [cd_type,] [id_ew])
21	!> @endcode
22	!> or
23	!> @code
24	!> tl_mpp=mpp_init( cd_file, td_var,
25	!> [id_niproc,] [id_njproc,] [id_nproc,]
26	!> [id_preci,] [id_precj,]
27	!> [cd_type] )
28	!> @endcode
29	!> or
30	!> @code
31	!> tl_mpp=mpp_init( td_file [,id_ew] )
32	!> @endcode
33	!> - cd_file is the filename of the global domain file, in which
34	!> MPP will be done (example: Bathymetry)
35	!> - td_file is the file structure of one processor file composing an MPP
36	!> - id_mask is the 2D mask of global domain [optional]
37	!> - td_var is a variable structure (on T-point) from global domain file.
38	!> mask of the domain will be computed using FillValue [optional]
39	!> - id_niproc is the number of processor following I-direction to be used
40	!> [optional]
41	!> - id_njproc is the number of processor following J-direction to be used
42	!> [optional]
43	!> - id_nproc is the total number of processor to be used [optional]
44	!> - id_preci is the size of the overlap region following I-direction [optional]
45	!> - id_precj is the size of the overlap region following J-direction [optional]
46	!> - cd_type is the type of files composing MPP [optional]
47	!> - id_ew is east-west overlap [optional]<br/>
48	!>
49	!> to get mpp name:<br/>
50	!> - tl_mpp\%c_name
51	!>
52	!> to get the total number of processor:<br/>
53	!> - tl_mpp\%i_nproc
54	!>
55	!> to get the number of processor following I-direction:<br/>
56	!> - tl_mpp\%i_niproc
57	!>
58	!> to get the number of processor following J-direction:<br/>
59	!> - tl_mpp\%i_njproc
60	!>
61	!> to get the length of the overlap region following I-direction:<br/>
62	!> - tl_mpp\%i_preci
63	!>
64	!> to get the length of the overlap region following J-direction:<br/>
65	!> - tl_mpp\%i_precj
66	!>
67	!> to get the type of files composing mpp structure:<br/>
68	!> - tl_mpp\%c_type
69	!>
70	!> to get the type of the global domain:<br/>
71	!> - tl_mpp\%c_dom
72	!>
73	!> MPP dimensions (global domain)<br/>
74	!> to get the number of dimensions to be used in mpp strcuture:<br/>
75	!> - tl_mpp\%i_ndim
76	!>
77	!> to get the array of dimension structure (4 elts) associated to the
78	!> mpp structure:<br/>
79	!> - tl_mpp\%t_dim(:)
80	!>
81	!> MPP processor (files composing domain)<br/>
82	!> - tl_mpp\%t_proc(:)
83	!>
84	!> to clean a mpp structure:<br/>
85	!> @code
86	!> CALL mpp_clean(tl_mpp)
87	!> @endcode
88	!>
89	!> to print information about mpp:<br/>
90	!> @code
91	!> CALL mpp_print(tl_mpp)
92	!> @endcode
93	!>
94	!> to add variable to mpp:<br/>
95	!> @code
96	!> CALL mpp_add_var(td_mpp, td_var)
97	!> @endcode
98	!> - td_var is a variable structure
99	!>
100	!> to add dimension to mpp:<br/>
101	!> @code
102	!> CALL mpp_add_dim(td_mpp, td_dim)
103	!> @endcode
104	!> - td_dim is a dimension structure
105	!>
106	!> to add attribute to mpp:<br/>
107	!> @code
108	!> CALL mpp_add_att(td_mpp, td_att)
109	!> @endcode
110	!> - td_att is a attribute structure
111	!>
112	!> to delete variable from mpp:<br/>
113	!> @code
114	!> CALL mpp_del_var(td_mpp, td_var)
115	!> @endcode
116	!> or
117	!> @code
118	!> CALL mpp_del_var(td_mpp, cd_name)
119	!> @endcode
120	!> - td_var is a variable structure
121	!> - cd_name is variable name or standard name
122	!>
123	!> to delete dimension from mpp:<br/>
124	!> @code
125	!> CALL mpp_del_dim(td_mpp, td_dim)
126	!> @endcode
127	!> - td_dim is a dimension structure
128	!>
129	!> to delete attribute from mpp:<br/>
130	!> @code
131	!> CALL mpp_del_att(td_mpp, td_att)
132	!> @endcode
133	!> or
134	!> @code
135	!> CALL mpp_del_att(td_mpp, cd_name)
136	!> @endcode
137	!> - td_att is a attribute structure
138	!> - cd_name is attribute name
139	!>
140	!> to overwrite variable to mpp:<br/>
141	!> @code
142	!> CALL mpp_move_var(td_mpp, td_var)
143	!> @endcode
144	!> - td_var is a variable structure
145	!>
146	!> to overwrite dimension to mpp:<br/>
147	!> @code
148	!> CALL mpp_move_dim(td_mpp, td_dim)
149	!> @endcode
150	!> - td_dim is a dimension structure
151	!>
152	!> to overwrite attribute to mpp:<br/>
153	!> @code
154	!> CALL mpp_move_att(td_mpp, td_att)
155	!> @endcode
156	!> - td_att is a attribute structure
157	!>
158	!> to determine domain decomposition type:<br/>
159	!> @code
160	!> CALL mpp_get_dom(td_mpp)
161	!> @endcode
162	!>
163	!> to get processors to be used:<br/>
164	!> @code
165	!> CALL mpp_get_use( td_mpp, id_imin, id_imax, &
166	!> & id_jmin, id_jmax )
167	!> @endcode
168	!> - id_imin
169	!> - id_imax
170	!> - id_jmin
171	!> - id_jmax
172	!>
173	!> to get sub domains which form global domain contour:<br/>
174	!> @code
175	!> CALL mpp_get_contour( td_mpp )
176	!> @endcode
177	!>
178	!> to get global domain indices of one processor:<br/>
179	!> @code
180	!> il_ind(1:4)=mpp_get_proc_index( td_mpp, id_procid )
181	!> @endcode
182	!> - il_ind(1:4) are global domain indices (i1,i2,j1,j2)
183	!> - id_procid is the processor id
184	!>
185	!> to get the processor domain size:<br/>
186	!> @code
187	!> il_size(1:2)=mpp_get_proc_size( td_mpp, id_procid )
188	!> @endcode
189	!> - il_size(1:2) are the size of domain following I and J
190	!> - id_procid is the processor id
191	!>
192	!> @author
193	!> J.Paul
194	!>
195	!> @date November, 2013 - Initial Version
196	!> @date November, 2014
197	!> - Fix memory leaks bug
198	!> @date October, 2015
199	!> - improve way to compute domain layout
200	!> @date January, 2016
201	!> - allow to print layout file (use lm_layout, hard coded)
202	!> - add mpp__compute_halo and mpp__read_halo
203	!>
204	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
205	!>
206	!> @todo
207	!> - ECRIRE ET TESTER add_proc_array pour optimiser codes (voir old/MO_mpp.f90)
208	!----------------------------------------------------------------------
209	MODULE mpp
210
211	USE global ! global parameter
212	USE kind ! F90 kind parameter
213	USE logger ! log file manager
214	USE fct ! basic useful function
215	USE dim ! dimension manager
216	USE att ! attribute manager
217	USE var ! variable manager
218	USE file ! file manager
219	USE iom ! I/O manager
220
221	IMPLICIT NONE
222	! NOTE_avoid_public_variables_if_possible
223
224	! type and variable
225	PUBLIC :: TMPP !< mpp structure
226	PRIVATE :: TLAY !< domain layout structure
227
228	! function and subroutine
229	PUBLIC :: mpp_copy !< copy mpp structure
230	PUBLIC :: mpp_init !< initialise mpp structure
231	PUBLIC :: mpp_clean !< clean mpp strcuture
232	PUBLIC :: mpp_print !< print information about mpp structure
233	PUBLIC :: mpp_add_var !< split/add one variable strucutre in mpp structure
234	PUBLIC :: mpp_add_dim !< add one dimension to mpp structure
235	PUBLIC :: mpp_add_att !< add one attribute strucutre in mpp structure
236	PUBLIC :: mpp_del_var !< delete one variable strucutre in mpp structure
237	PUBLIC :: mpp_del_dim !< delete one dimension strucutre in mpp structure
238	PUBLIC :: mpp_del_att !< delete one attribute strucutre in mpp structure
239	PUBLIC :: mpp_move_var !< overwrite variable structure in mpp structure
240	PUBLIC :: mpp_move_dim !< overwrite one dimension strucutre in mpp structure
241	PUBLIC :: mpp_move_att !< overwrite one attribute strucutre in mpp structure
242	PUBLIC :: mpp_recombine_var !< recombine variable from mpp structure
243	PUBLIC :: mpp_get_index !< return index of mpp
244
245	PUBLIC :: mpp_get_dom !< determine domain decomposition type (full, overlap, noverlap)
246	PUBLIC :: mpp_get_use !< get sub domains to be used (which cover "zoom domain")
247	PUBLIC :: mpp_get_contour !< get sub domains which form global domain contour
248	PUBLIC :: mpp_get_proc_index !< get processor domain indices
249	PUBLIC :: mpp_get_proc_size !< get processor domain size
250
251	PRIVATE :: mpp__add_proc ! add proc strucutre in mpp structure
252	PRIVATE :: mpp__add_proc_unit ! add one proc strucutre in mpp structure
253	PRIVATE :: mpp__add_proc_arr ! add array of proc strucutre in mpp structure
254	PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure
255	PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id
256	PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure
257	PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure
258	PRIVATE :: mpp__create_layout ! create mpp structure using domain layout
259	PRIVATE :: mpp__optimiz ! compute optimum domain decomposition
260	PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension
261	PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension
262	PRIVATE :: mpp__check_var_dim ! check if variable and mpp structure use same dimension
263	PRIVATE :: mpp__del_var_name ! delete variable in mpp structure, given variable name
264	PRIVATE :: mpp__del_var_mpp ! delete all variable in mpp structure
265	PRIVATE :: mpp__del_var_str ! delete variable in mpp structure, given variable structure
266	PRIVATE :: mpp__del_att_name ! delete variable in mpp structure, given variable name
267	PRIVATE :: mpp__del_att_str ! delete variable in mpp structure, given variable structure
268	PRIVATE :: mpp__split_var ! extract variable part that will be written in processor
269	PRIVATE :: mpp__copy_unit ! copy mpp structure
270	PRIVATE :: mpp__copy_arr ! copy array of mpp structure
271	PRIVATE :: mpp__get_use_unit ! get sub domains to be used (which cover "zoom domain")
272	PRIVATE :: mpp__init_mask ! initialise mpp structure, given mask array
273	PRIVATE :: mpp__init_var ! initialise mpp structure, given variable strcuture
274	PRIVATE :: mpp__init_file ! initialise a mpp structure, given file structure
275	PRIVATE :: mpp__init_file_cdf ! initialise a mpp structure with cdf file
276	PRIVATE :: mpp__init_file_rstdimg ! initialise a mpp structure with rstdimg file
277	PRIVATE :: mpp__clean_unit ! clean mpp strcuture
278	PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture
279	PRIVATE :: mpp__compute_halo ! compute subdomain indices defined with halo
280	PRIVATE :: mpp__read_halo ! read subdomain indices defined with halo
281
282	PRIVATE :: layout__init ! initialise domain layout structure
283	PRIVATE :: layout__copy ! clean domain layout structure
284	PRIVATE :: layout__clean ! copy domain layout structure
285
286	TYPE TMPP !< mpp structure
287	! general
288	CHARACTER(LEN=lc) :: c_name = '' !< base name
289	INTEGER(i4) :: i_id = 0 !< mpp id
290
291	INTEGER(i4) :: i_niproc = 0 !< number of processors following i
292	INTEGER(i4) :: i_njproc = 0 !< number of processors following j
293	INTEGER(i4) :: i_nproc = 0 !< total number of proccessors used
294	INTEGER(i4) :: i_preci = 1 !< i-direction overlap region length
295	INTEGER(i4) :: i_precj = 1 !< j-direction overlap region length
296	INTEGER(i4) :: i_ew = -1 !< east-west overlap
297	INTEGER(i4) :: i_perio = -1 !< NEMO periodicity index
298	INTEGER(i4) :: i_pivot = -1 !< NEMO pivot point index F(0),T(1)
299
300	CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg)
301	CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, noextra, nooverlap)
302
303	INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp
304	TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension
305
306	TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp
307
308	LOGICAL :: l_usempp = .TRUE. !< use mpp decomposition for writing netcdf
309	END TYPE
310
311	TYPE TLAY !< domain layout structure
312	INTEGER(i4) :: i_niproc = 0 !< number of processors following i
313	INTEGER(i4) :: i_njproc = 0 !< number of processors following j
314	INTEGER(i4) :: i_nland = 0 !< number of land processors
315	INTEGER(i4) :: i_nsea = 0 !< number of sea processors
316	INTEGER(i4) :: i_mean = 0 !< mean sea point per proc
317	INTEGER(i4) :: i_min = 0 !< min sea point per proc
318	INTEGER(i4) :: i_max = 0 !< max sea point per proc
319	INTEGER(i4), DIMENSION(:,:), POINTER :: i_msk => NULL() !< sea/land processor mask
320	INTEGER(i4), DIMENSION(:,:), POINTER :: i_impp => NULL() !< i-indexes for mpp-subdomain left bottom
321	INTEGER(i4), DIMENSION(:,:), POINTER :: i_jmpp => NULL() !< j-indexes for mpp-subdomain left bottom
322	INTEGER(i4), DIMENSION(:,:), POINTER :: i_lci => NULL() !< i-dimensions of subdomain
323	INTEGER(i4), DIMENSION(:,:), POINTER :: i_lcj => NULL() !< j-dimensions of subdomain
324	END TYPE
325
326	! module variable
327	INTEGER(i4) :: im_psize = 2000 !< processor dimension length for huge file
328
329	INTEGER(i4) :: im_iumout = 44
330	LOGICAL :: lm_layout =.FALSE.
331
332	INTERFACE mpp_get_use
333	MODULE PROCEDURE mpp__get_use_unit
334	END INTERFACE mpp_get_use
335
336	INTERFACE mpp__add_proc
337	MODULE PROCEDURE mpp__add_proc_unit
338	MODULE PROCEDURE mpp__add_proc_arr
339	END INTERFACE mpp__add_proc
340
341	INTERFACE mpp_clean
342	MODULE PROCEDURE mpp__clean_unit
343	MODULE PROCEDURE mpp__clean_arr
344	END INTERFACE mpp_clean
345
346	INTERFACE mpp__check_dim
347	MODULE PROCEDURE mpp__check_proc_dim !< check if processor and mpp structure use same dimension
348	MODULE PROCEDURE mpp__check_var_dim !< check if variable and mpp structure use same dimension
349	END INTERFACE mpp__check_dim
350
351	INTERFACE mpp__del_proc
352	MODULE PROCEDURE mpp__del_proc_id
353	MODULE PROCEDURE mpp__del_proc_str
354	END INTERFACE mpp__del_proc
355
356	INTERFACE mpp_del_var
357	MODULE PROCEDURE mpp__del_var_name
358	MODULE PROCEDURE mpp__del_var_str
359	MODULE PROCEDURE mpp__del_var_mpp
360	END INTERFACE mpp_del_var
361
362	INTERFACE mpp_del_att
363	MODULE PROCEDURE mpp__del_att_name
364	MODULE PROCEDURE mpp__del_att_str
365	END INTERFACE mpp_del_att
366
367	INTERFACE mpp_init
368	MODULE PROCEDURE mpp__init_mask
369	MODULE PROCEDURE mpp__init_var
370	MODULE PROCEDURE mpp__init_file
371	END INTERFACE mpp_init
372
373	INTERFACE mpp_copy
374	MODULE PROCEDURE mpp__copy_unit ! copy mpp structure
375	MODULE PROCEDURE mpp__copy_arr ! copy array of mpp structure
376	END INTERFACE
377
378	CONTAINS
379	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
380	FUNCTION mpp__copy_unit(td_mpp) &
381	& RESULT(tf_mpp)
382	!-------------------------------------------------------------------
383	!> @brief
384	!> This subroutine copy mpp structure in another one
385	!> @details
386	!> mpp file are copied in a temporary array,
387	!> so input and output mpp structure do not point on the same
388	!> "memory cell", and so on are independant.
389	!>
390	!> @warning do not use on the output of a function who create or read an
391	!> structure (ex: tl_file=file_copy(file_init()) is forbidden).
392	!> This will create memory leaks.
393	!> @warning to avoid infinite loop, do not use any function inside
394	!> this subroutine
395	!>
396	!> @author J.Paul
397	!> @date November, 2013 - Initial Version
398	!> @date November, 2014
399	!> - use function instead of overload assignment operator
400	!> (to avoid memory leak)
401	!> @date January, 2019
402	!> - clean file structure
403	!>
404	!> @param[in] td_mpp mpp structure
405	!> @return copy of input mpp structure
406	!-------------------------------------------------------------------
407
408	IMPLICIT NONE
409
410	! Argument
411	TYPE(TMPP), INTENT(IN) :: td_mpp
412
413	! function
414	TYPE(TMPP) :: tf_mpp
415
416	! local variable
417	TYPE(TFILE) :: tl_file
418
419	! loop indices
420	INTEGER(i4) :: ji
421	!----------------------------------------------------------------
422
423	CALL logger_trace("MPP COPY: "//TRIM(td_mpp%c_name)//" in "//&
424	& TRIM(tf_mpp%c_name))
425
426	! copy mpp variable
427	tf_mpp%c_name = TRIM(td_mpp%c_name)
428	tf_mpp%i_id = td_mpp%i_id
429	tf_mpp%i_niproc = td_mpp%i_niproc
430	tf_mpp%i_njproc = td_mpp%i_njproc
431	tf_mpp%i_nproc = td_mpp%i_nproc
432	tf_mpp%i_preci = td_mpp%i_preci
433	tf_mpp%i_precj = td_mpp%i_precj
434	tf_mpp%c_type = TRIM(td_mpp%c_type)
435	tf_mpp%c_dom = TRIM(td_mpp%c_dom)
436	tf_mpp%i_ndim = td_mpp%i_ndim
437	tf_mpp%i_ew = td_mpp%i_ew
438	tf_mpp%i_perio = td_mpp%i_perio
439	tf_mpp%i_pivot = td_mpp%i_pivot
440	tf_mpp%l_usempp = td_mpp%l_usempp
441
442	! copy dimension
443	tf_mpp%t_dim(:) = dim_copy(td_mpp%t_dim(:))
444
445	! copy file structure
446	IF( ASSOCIATED(tf_mpp%t_proc) )THEN
447	CALL file_clean(tf_mpp%t_proc(:))
448	DEALLOCATE(tf_mpp%t_proc)
449	ENDIF
450	IF( ASSOCIATED(td_mpp%t_proc) .AND. tf_mpp%i_nproc > 0 )THEN
451	ALLOCATE( tf_mpp%t_proc(tf_mpp%i_nproc) )
452	DO ji=1,tf_mpp%i_nproc
453	tl_file = file_copy(td_mpp%t_proc(ji))
454	tf_mpp%t_proc(ji) = file_copy(tl_file)
455	ENDDO
456	! clean
457	CALL file_clean(tl_file)
458	ENDIF
459
460	END FUNCTION mpp__copy_unit
461	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
462	FUNCTION mpp__copy_arr(td_mpp) &
463	& RESULT(tf_mpp)
464	!-------------------------------------------------------------------
465	!> @brief
466	!> This subroutine copy an array of mpp structure in another one
467	!> @details
468	!> mpp file are copied in a temporary array,
469	!> so input and output mpp structure do not point on the same
470	!> "memory cell", and so on are independant.
471	!>
472	!> @warning do not use on the output of a function who create or read an
473	!> structure (ex: tl_file=file_copy(file_init()) is forbidden).
474	!> This will create memory leaks.
475	!> @warning to avoid infinite loop, do not use any function inside
476	!> this subroutine
477	!>
478	!> @author J.Paul
479	!> @date November, 2013 - Initial Version
480	!> @date November, 2014
481	!> - use function instead of overload assignment operator
482	!> (to avoid memory leak)
483	!>
484	!> @param[in] td_mpp mpp structure
485	!> @return copy of input array of mpp structure
486	!-------------------------------------------------------------------
487
488	IMPLICIT NONE
489
490	! Argument
491	TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp
492
493	! function
494	TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: tf_mpp
495
496	! local variable
497	! loop indices
498	INTEGER(i4) :: ji
499	!----------------------------------------------------------------
500
501	DO ji=1,SIZE(td_mpp(:))
502	tf_mpp(ji)=mpp_copy(td_mpp(ji))
503	ENDDO
504
505	END FUNCTION mpp__copy_arr
506	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
507	SUBROUTINE mpp_print(td_mpp)
508	!-------------------------------------------------------------------
509	!> @brief This subroutine print some information about mpp strucutre.
510	!>
511	!> @author J.Paul
512	!> @date November, 2013 - Initial Version
513	!>
514	!> @param[in] td_mpp mpp structure
515	!-------------------------------------------------------------------
516
517	IMPLICIT NONE
518
519	! Argument
520	TYPE(TMPP), INTENT(IN) :: td_mpp
521
522	! local variable
523	INTEGER(i4), PARAMETER :: ip_freq = 4
524	INTEGER(i4), PARAMETER :: ip_min = 5
525
526	INTEGER(i4) :: il_min
527	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_proc
528	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lci
529	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lcj
530
531	! loop indices
532	INTEGER(i4) :: ji
533	INTEGER(i4) :: jj
534	INTEGER(i4) :: jk
535	INTEGER(i4) :: jl
536	INTEGER(i4) :: jm
537	!----------------------------------------------------------------
538
539	WRITE(*,'((a,a),2(/3x,a,a),9(/3x,a,i0))')&
540	& "MPP : ",TRIM(td_mpp%c_name), &
541	& " type : ",TRIM(td_mpp%c_type), &
542	& " dom : ",TRIM(td_mpp%c_dom), &
543	& " nproc : ",td_mpp%i_nproc, &
544	& " niproc : ",td_mpp%i_niproc, &
545	& " njproc : ",td_mpp%i_njproc, &
546	& " preci : ",td_mpp%i_preci, &
547	& " precj : ",td_mpp%i_precj, &
548	& " ndim : ",td_mpp%i_ndim, &
549	& " overlap: ",td_mpp%i_ew, &
550	& " perio : ",td_mpp%i_perio, &
551	& " pivot : ",td_mpp%i_pivot
552
553	! print dimension
554	IF( td_mpp%i_ndim /= 0 )THEN
555	WRITE(*,'(/a)') " MPP dimension"
556	DO ji=1,ip_maxdim
557	IF( td_mpp%t_dim(ji)%l_use )THEN
558	CALL dim_print(td_mpp%t_dim(ji))
559	ENDIF
560	ENDDO
561	ENDIF
562
563	! print file
564	IF( td_mpp%i_nproc /= 0 .AND. ASSOCIATED(td_mpp%t_proc) )THEN
565	IF( ALL( td_mpp%t_proc(:)%i_iind==0 ) .OR. &
566	& ALL( td_mpp%t_proc(:)%i_jind==0 ) )THEN
567
568	il_min=MIN(td_mpp%i_nproc,ip_min)
569	DO ji=1,il_min
570	CALL file_print(td_mpp%t_proc(ji))
571	WRITE(*,'((a),(/3x,a,i0),2(/3x,a,a),4(/3x,a,i0,a,i0)/)')&
572	& " Domain decomposition : ", &
573	& " id : ",td_mpp%t_proc(ji)%i_pid, &
574	& " used : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_use)), &
575	& " contour : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_ctr)), &
576	& " left-bottom : ",td_mpp%t_proc(ji)%i_impp,', ',&
577	& td_mpp%t_proc(ji)%i_jmpp, &
578	& " dimension : ",td_mpp%t_proc(ji)%i_lci,' x ',&
579	& td_mpp%t_proc(ji)%i_lcj, &
580	& " first indoor indices : ",td_mpp%t_proc(ji)%i_ldi,', ',&
581	& td_mpp%t_proc(ji)%i_ldj, &
582	& " last indoor indices : ",td_mpp%t_proc(ji)%i_lei,', ',&
583	& td_mpp%t_proc(ji)%i_lej
584
585	ENDDO
586	IF( td_mpp%i_nproc > ip_min )THEN
587	WRITE(*,'(a)') "...etc"
588	ENDIF
589
590	IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN
591	WRITE(*,'(/a)') " Variable(s) used : "
592	DO ji=1,td_mpp%t_proc(1)%i_nvar
593	WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)
594	ENDDO
595	ENDIF
596
597	ELSE
598
599	il_min=MIN(td_mpp%i_nproc,ip_min)
600	DO ji=1,il_min
601	CALL file_print(td_mpp%t_proc(ji))
602	WRITE(*,'((a, a),(/3x,a,i0),(/3x,a,a),4(/3x,a,i0,a,i0)/)')&
603	& " Domain decomposition : ",TRIM(td_mpp%t_proc(ji)%c_name),&
604	& " id : ",td_mpp%t_proc(ji)%i_pid, &
605	& " used : ",TRIM(fct_str(td_mpp%t_proc(ji)%l_use)),&
606	& " left-bottom : ",td_mpp%t_proc(ji)%i_impp,', ',&
607	& td_mpp%t_proc(ji)%i_jmpp, &
608	& " dimension : ",td_mpp%t_proc(ji)%i_lci,' x ',&
609	& td_mpp%t_proc(ji)%i_lcj, &
610	& " first indoor indices : ",td_mpp%t_proc(ji)%i_ldi,',',&
611	& td_mpp%t_proc(ji)%i_ldj, &
612	& " last indoor indices : ",td_mpp%t_proc(ji)%i_lei,', ',&
613	& td_mpp%t_proc(ji)%i_lej
614
615	ENDDO
616	IF( td_mpp%i_nproc > ip_min )THEN
617	WRITE(*,'(a)') "...etc"
618	ENDIF
619
620	IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN
621	WRITE(*,'(/a)') " Variable(s) used : "
622	DO ji=1,td_mpp%t_proc(1)%i_nvar
623	WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)
624	ENDDO
625	ENDIF
626
627	IF( td_mpp%l_usempp )THEN
628	ALLOCATE( il_proc(td_mpp%i_niproc,td_mpp%i_njproc) )
629	ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) )
630	ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) )
631	il_proc(:,:)=-1
632	il_lci(:,:) =-1
633	il_lcj(:,:) =-1
634
635	DO jk=1,td_mpp%i_nproc
636	ji=td_mpp%t_proc(jk)%i_iind
637	jj=td_mpp%t_proc(jk)%i_jind
638	il_proc(ji,jj)=jk-1
639	il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci
640	il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj
641	ENDDO
642
643	jl = 1
644	DO jk = 1,(td_mpp%i_niproc-1)/ip_freq+1
645	jm = MIN(td_mpp%i_niproc, jl+ip_freq-1)
646	WRITE(,)
647	WRITE(*,9401) (ji, ji = jl,jm)
648	WRITE(,9400) ('**', ji = jl,jm-1)
649	DO jj = 1, td_mpp%i_njproc
650	WRITE(*,9403) (' ', ji = jl,jm-1)
651	WRITE(*,9402) jj, ( il_lci(ji,jj), il_lcj(ji,jj), ji = jl,jm)
652	WRITE(*,9404) (il_proc(ji,jj), ji= jl,jm)
653	WRITE(*,9403) (' ', ji = jl,jm-1)
654	WRITE(,9400) ('**', ji = jl,jm-1)
655	ENDDO
656	jl = jl+ip_freq
657	ENDDO
658
659	DEALLOCATE( il_proc )
660	DEALLOCATE( il_lci )
661	DEALLOCATE( il_lcj )
662	ENDIF
663
664	ENDIF
665	ELSE
666	WRITE(*,'(/a)') " Domain decomposition : none"
667	ENDIF
668
669	9400 FORMAT(' *',20('***********',a3))
670	9403 FORMAT(' * ',20(' * ',a3))
671	9401 FORMAT(' ',20(' ',i3,' '))
672	9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * '))
673	9404 FORMAT(' * ',20(' ',i3,' * '))
674
675	END SUBROUTINE mpp_print
676	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
677	FUNCTION mpp__init_mask(cd_file, id_mask, &
678	& id_niproc, id_njproc, id_nproc, &
679	& id_preci, id_precj, &
680	& cd_type, id_ew, id_perio, id_pivot, &
681	& td_dim, ld_usempp) &
682	& RESULT(tf_mpp)
683	!-------------------------------------------------------------------
684	!> @brief
685	!> This function initialise mpp structure, given file name,
686	!> and optionaly mask and number of processor following I and J
687	!> @detail
688	!> - If no total number of processor is defined (id_nproc), optimize
689	!> the domain decomposition (look for the domain decomposition with
690	!> the most land processor to remove)
691	!> - length of the overlap region (id_preci, id_precj) could be specify
692	!> in I and J direction (default value is 1)
693	!>
694	!> @author J.Paul
695	!> @date November, 2013 - Initial version
696	!> @date September, 2015
697	!> - allow to define dimension with array of dimension structure
698	!> @date January, 2016
699	!> - use RESULT to rename output
700	!> - mismatch with "halo" indices
701	!> @date July, 2020
702	!> - call dim_reorder for each proc file
703	!>
704	!> @param[in] cd_file file name of one file composing mpp domain
705	!> @param[in] id_mask domain mask
706	!> @param[in] id_niproc number of processors following i
707	!> @param[in] id_njproc number of processors following j
708	!> @param[in] id_nproc total number of processors
709	!> @param[in] id_preci i-direction overlap region
710	!> @param[in] id_precj j-direction overlap region
711	!> @param[in] cd_type type of the files (cdf, cdf4, dimg)
712	!> @param[in] id_ew east-west overlap
713	!> @param[in] id_perio NEMO periodicity index
714	!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
715	!> @param[in] td_dim array of dimension structure
716	!> @return mpp structure
717	!-------------------------------------------------------------------
718
719	IMPLICIT NONE
720
721	! Argument
722	CHARACTER(LEN=*), INTENT(IN) :: cd_file
723	INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
724	INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc
725	INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc
726	INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc
727	INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci
728	INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj
729	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
730	INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
731	INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
732	INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
733	TYPE(TDIM) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: td_dim
734	LOGICAL , INTENT(IN), OPTIONAL :: ld_usempp
735
736	! function
737	TYPE(TMPP) :: tf_mpp
738
739	! local variable
740	CHARACTER(LEN=lc) :: cl_type
741
742	INTEGER(i4) , DIMENSION(2) :: il_shape
743	INTEGER(i4) :: il_niproc
744	INTEGER(i4) :: il_njproc
745
746	TYPE(TDIM) :: tl_dim
747
748	TYPE(TATT) :: tl_att
749
750	TYPE(TLAY) :: tl_lay
751
752	! loop indices
753	INTEGER(i4) :: ji
754	!----------------------------------------------------------------
755
756	! clean mpp
757	CALL mpp_clean(tf_mpp)
758
759	! check type
760	cl_type=''
761	IF( PRESENT(cd_type) ) cl_type=TRIM(ADJUSTL(cd_type))
762
763	IF( TRIM(cl_type) /= '' )THEN
764	SELECT CASE(TRIM(cd_type))
765	CASE('cdf')
766	tf_mpp%c_type='cdf'
767	CASE('dimg')
768	tf_mpp%c_type='dimg'
769	CASE DEFAULT
770	CALL logger_warn("MPP INIT: type "//TRIM(cd_type)//&
771	& " unknown. type dimg will be used for mpp "//&
772	& TRIM(tf_mpp%c_name) )
773	tf_mpp%c_type='dimg'
774	END SELECT
775	ELSE
776	tf_mpp%c_type=TRIM(file_get_type(cd_file))
777	ENDIF
778
779	! get mpp name
780	tf_mpp%c_name=TRIM(file_rename(cd_file))
781
782	! get global domain dimension
783	il_shape(:)=SHAPE(id_mask)
784
785	IF( PRESENT(td_dim) )THEN
786	DO ji=1,ip_maxdim
787	IF( td_dim(ji)%l_use )THEN
788	CALL mpp_add_dim(tf_mpp, td_dim(ji))
789	ENDIF
790	ENDDO
791	ELSE
792	tl_dim=dim_init('X',il_shape(1))
793	CALL mpp_add_dim(tf_mpp, tl_dim)
794
795	tl_dim=dim_init('Y',il_shape(2))
796	CALL mpp_add_dim(tf_mpp, tl_dim)
797
798	! clean
799	CALL dim_clean(tl_dim)
800	ENDIF
801
802	IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. &
803	((.NOT. PRESENT(id_niproc)) .AND. PRESENT(id_njproc) ) )THEN
804	CALL logger_warn( "MPP INIT: number of processors following I and J "//&
805	& "should be both specified")
806	ELSE
807	! get number of processors following I and J
808	IF( PRESENT(id_niproc) ) tf_mpp%i_niproc=id_niproc
809	IF( PRESENT(id_njproc) ) tf_mpp%i_njproc=id_njproc
810	ENDIF
811
812	! get maximum number of processors to be used
813	IF( PRESENT(id_nproc) ) tf_mpp%i_nproc = id_nproc
814
815	! get overlap region length
816	IF( PRESENT(id_preci) ) tf_mpp%i_preci= id_preci
817	IF( PRESENT(id_precj) ) tf_mpp%i_precj= id_precj
818
819	! east-west overlap
820	IF( PRESENT(id_ew) ) tf_mpp%i_ew= id_ew
821	! NEMO periodicity
822	IF( PRESENT(id_perio) ) tf_mpp%i_perio= id_perio
823	IF( PRESENT(id_pivot) ) tf_mpp%i_pivot= id_pivot
824	!
825	IF( PRESENT(ld_usempp) ) tf_mpp%l_usempp = ld_usempp
826
827	IF( tf_mpp%i_nproc /= 0 .AND. &
828	& tf_mpp%i_niproc /= 0 .AND. &
829	& tf_mpp%i_njproc /= 0 .AND. &
830	& tf_mpp%i_nproc > tf_mpp%i_niproc * tf_mpp%i_njproc )THEN
831
832	CALL logger_error("MPP INIT: invalid domain decomposition ")
833	CALL logger_debug("MPP INIT: "// &
834	& TRIM(fct_str(tf_mpp%i_nproc))//" > "//&
835	& TRIM(fct_str(tf_mpp%i_niproc))//" x "//&
836	& TRIM(fct_str(tf_mpp%i_njproc)) )
837
838	ELSE
839	IF( lm_layout )THEN
840	OPEN(im_iumout,FILE='processor.layout')
841	WRITE(im_iumout,*)
842	WRITE(im_iumout,*) ' optimisation de la partition'
843	WRITE(im_iumout,*) ' ----------------------------'
844	WRITE(im_iumout,*)
845	ENDIF
846
847	IF( tf_mpp%i_niproc /= 0 .AND. tf_mpp%i_njproc /= 0 .AND. &
848	&(tf_mpp%i_niproc > 1 .OR. tf_mpp%i_njproc > 1) )THEN
849
850	! compute domain layout
851	tl_lay=layout__init(tf_mpp, id_mask, &
852	& tf_mpp%i_niproc, tf_mpp%i_njproc)
853	! create mpp domain layout
854	CALL mpp__create_layout( tf_mpp, tl_lay )
855
856	! clean
857	CALL layout__clean( tl_lay )
858
859	ELSEIF( tf_mpp%i_nproc > 1 )THEN
860
861	! optimiz
862	CALL mpp__optimiz( tf_mpp, id_mask, tf_mpp%i_nproc )
863
864	ELSE
865
866	CALL logger_warn("MPP INIT: number of processor to be used "//&
867	& "not specify. force output on one file.")
868	! number of proc to get proc size close to im_psize
869	il_niproc=INT(il_shape(jp_I)/im_psize)+1
870	il_njproc=INT(il_shape(jp_J)/im_psize)+1
871
872	tf_mpp%l_usempp=.FALSE.
873	tl_lay=layout__init( tf_mpp, id_mask, &
874	& il_niproc, il_njproc )
875
876	! create mpp domain layout
877	CALL mpp__create_layout( tf_mpp, tl_lay )
878
879	! clean
880	CALL layout__clean( tl_lay )
881
882	ENDIF
883
884	CALL logger_info("MPP INIT: domain decoposition : "//&
885	& 'niproc('//TRIM(fct_str(tf_mpp%i_niproc))//') * '//&
886	& 'njproc('//TRIM(fct_str(tf_mpp%i_njproc))//') = '//&
887	& 'nproc('//TRIM(fct_str(tf_mpp%i_nproc))//')' )
888
889	! get domain type
890	CALL mpp_get_dom( tf_mpp )
891
892	DO ji=1,tf_mpp%i_nproc
893
894	! get processor size
895	il_shape(:)=mpp_get_proc_size( tf_mpp, ji )
896
897	tl_dim=dim_init('X',il_shape(1))
898	CALL file_move_dim(tf_mpp%t_proc(ji), tl_dim)
899
900	tl_dim=dim_init('Y',il_shape(2))
901	CALL file_move_dim(tf_mpp%t_proc(ji), tl_dim)
902
903	IF( PRESENT(td_dim) )THEN
904	IF( td_dim(jp_K)%l_use )THEN
905	CALL file_move_dim(tf_mpp%t_proc(ji), td_dim(jp_K))
906	ENDIF
907	IF( td_dim(jp_L)%l_use )THEN
908	CALL file_move_dim(tf_mpp%t_proc(ji), td_dim(jp_L))
909	ENDIF
910	ENDIF
911	! add type
912	tf_mpp%t_proc(ji)%c_type=TRIM(tf_mpp%c_type)
913
914	! reorder dimension
915	CALL dim_reorder(tf_mpp%t_proc(ji)%t_dim(:))
916
917	! clean
918	CALL dim_clean(tl_dim)
919
920	ENDDO
921
922	! add global attribute
923	tl_att=att_init("DOMAIN_number_total",tf_mpp%i_nproc)
924	CALL mpp_add_att(tf_mpp, tl_att)
925
926	tl_att=att_init("DOMAIN_LOCAL",TRIM(tf_mpp%c_dom))
927	CALL mpp_add_att(tf_mpp, tl_att)
928
929	tl_att=att_init("DOMAIN_I_number_total",tf_mpp%i_niproc)
930	CALL mpp_add_att(tf_mpp, tl_att)
931
932	tl_att=att_init("DOMAIN_J_number_total",tf_mpp%i_njproc)
933	CALL mpp_add_att(tf_mpp, tl_att)
934
935	tl_att=att_init("DOMAIN_size_global",tf_mpp%t_dim(1:2)%i_len)
936	CALL mpp_add_att(tf_mpp, tl_att)
937
938	CALL mpp__compute_halo(tf_mpp)
939	ENDIF
940
941	END FUNCTION mpp__init_mask
942	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
943	FUNCTION mpp__init_var(cd_file, td_var, &
944	& id_niproc, id_njproc, id_nproc,&
945	& id_preci, id_precj, cd_type, &
946	& id_perio, id_pivot, ld_usempp) &
947	& RESULT(tf_mpp)
948	!-------------------------------------------------------------------
949	!> @brief
950	!> This function initialise mpp structure, given variable strcuture
951	!> and optionaly number of processor following I and J
952	!> @detail
953	!> - If no total number of processor is defined (id_nproc), optimize
954	!> the domain decomposition (look for the domain decomposition with
955	!> the most land processor to remove)
956	!> - length of the overlap region (id_preci, id_precj) could be specify
957	!> in I and J direction (default value is 1)
958	!>
959	!> @author J.Paul
960	!> @date November, 2013 - Initial version
961	!> @date July, 2020
962	!> - add variable dimension argument to set up mpp structure
963	!>
964	!> @param[in] cd_file file name of one file composing mpp domain
965	!> @param[in] td_var variable structure
966	!> @param[in] id_niproc number of processors following i
967	!> @param[in] id_njproc number of processors following j
968	!> @param[in] id_nproc total number of processors
969	!> @param[in] id_preci i-direction overlap region
970	!> @param[in] id_precj j-direction overlap region
971	!> @param[in] cd_type type of the files (cdf, cdf4, dimg)
972	!> @param[in] id_perio NEMO periodicity index
973	!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
974	!> @return mpp structure
975	!-------------------------------------------------------------------
976
977	IMPLICIT NONE
978
979	! Argument
980	CHARACTER(LEN=*), INTENT(IN) :: cd_file
981	TYPE(TVAR), INTENT(IN) :: td_var
982	INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc
983	INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc
984	INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc
985	INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci
986	INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj
987	CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
988	INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
989	INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
990	LOGICAL, INTENT(IN), OPTIONAL :: ld_usempp
991
992	! function
993	TYPE(TMPP) :: tf_mpp
994
995	! local variable
996	INTEGER(i4), DIMENSION(:,:,:), ALLOCATABLE :: il_mask
997	!----------------------------------------------------------------
998
999	IF( ASSOCIATED(td_var%d_value) )THEN
1000	ALLOCATE( il_mask(td_var%t_dim(1)%i_len, &
1001	& td_var%t_dim(2)%i_len, &
1002	& td_var%t_dim(3)%i_len) )
1003	il_mask(:,:,:)=var_get_mask(td_var)
1004
1005	CALL logger_info("MPP INIT: mask compute from variable "//&
1006	& TRIM(td_var%c_name))
1007	tf_mpp = mpp_init( cd_file, il_mask(:,:,1), &
1008	& id_niproc, id_njproc, id_nproc,&
1009	& id_preci, id_precj, cd_type, &
1010	& id_ew=td_var%i_ew, &
1011	& id_perio=id_perio, id_pivot=id_pivot,&
1012	& td_dim=td_var%t_dim(:), &
1013	& ld_usempp=ld_usempp)
1014
1015	DEALLOCATE(il_mask)
1016	ELSE
1017	CALL logger_error("MPP INIT: variable value not define.")
1018	ENDIF
1019
1020	END FUNCTION mpp__init_var
1021	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1022	FUNCTION mpp__init_file(td_file, id_ew, id_perio, id_pivot) &
1023	& RESULT(tf_mpp)
1024	!-------------------------------------------------------------------
1025	!> @brief This function initalise a mpp structure given file structure.
1026	!> @details
1027	!> It reads restart dimg files, or some netcdf files.
1028	!>
1029	!> @warning
1030	!> netcdf file must contains some attributes:
1031	!> - DOMAIN_number_total
1032	!> - DOMAIN_size_global
1033	!> - DOMAIN_number
1034	!> - DOMAIN_position_first
1035	!> - DOMAIN_position_last
1036	!> - DOMAIN_halo_size_start
1037	!> - DOMAIN_halo_size_end
1038	!> or the file is assume to be no mpp file.
1039	!>
1040	!> @author J.Paul
1041	!> @date November, 2013 - Initial Version
1042	!> @date January, 2016
1043	!> - mismatch with "halo" indices, use mpp__compute_halo
1044	!> @date Marsh, 2017
1045	!> - netcdf proc indices from zero to N-1
1046	!> - copy file periodicity to mpp structure
1047	!> @date August, 2017
1048	!> - force to use domain decomposition to enhance read of monoproc file
1049	!>
1050	!> @param[in] td_file file strcuture
1051	!> @param[in] id_ew east-west overlap
1052	!> @param[in] id_perio NEMO periodicity index
1053	!> @param[in] id_pivot NEMO pivot point index F(0),T(1)
1054	!> @return mpp structure
1055	!-------------------------------------------------------------------
1056
1057	IMPLICIT NONE
1058
1059	! Argument
1060	TYPE(TFILE), INTENT(IN) :: td_file
1061	INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew
1062	INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio
1063	INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot
1064
1065	! function
1066	TYPE(TMPP) :: tf_mpp
1067
1068	! local variable
1069	INTEGER(i4) :: il_nproc
1070	INTEGER(i4) :: il_attid
1071	INTEGER(i4), DIMENSION(2) :: il_shape
1072
1073	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask
1074	INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim
1075	INTEGER(i4) :: il_niproc
1076	INTEGER(i4) :: il_njproc
1077
1078	TYPE(TDIM) :: tl_dim
1079
1080	TYPE(TATT) :: tl_att
1081
1082	TYPE(TFILE) :: tl_file
1083
1084	TYPE(TMPP) :: tl_mpp
1085
1086	! loop indices
1087	INTEGER(i4) :: ji
1088	!----------------------------------------------------------------
1089
1090	! clean mpp
1091	CALL mpp_clean(tf_mpp)
1092
1093	! check file type
1094	SELECT CASE( TRIM(td_file%c_type) )
1095	CASE('cdf')
1096	! need to read all file to get domain decomposition
1097	tl_file=file_copy(td_file)
1098
1099	! open file
1100	CALL iom_open(tl_file)
1101
1102	! read first file domain decomposition
1103	tl_mpp=mpp__init_file_cdf(tl_file)
1104
1105	! get number of processor/file to be read
1106	il_nproc = 1
1107	il_attid = 0
1108
1109	IF( ASSOCIATED(tl_file%t_att) )THEN
1110	il_attid=att_get_id( tl_file%t_att, "DOMAIN_number_total" )
1111	ENDIF
1112	IF( il_attid /= 0 )THEN
1113	il_nproc = INT(tl_file%t_att(il_attid)%d_value(1))
1114	ENDIF
1115
1116	! close file
1117	CALL iom_close(tl_file)
1118
1119	IF( il_nproc /= 1 )THEN
1120
1121	DO ji=1,il_nproc
1122
1123	! clean mpp strcuture
1124	CALL mpp_clean(tl_mpp)
1125
1126	! get filename (from 0 to n-1)
1127	tl_file=file_rename(td_file,ji-1)
1128
1129	! open file
1130	CALL iom_open(tl_file)
1131
1132	! read domain decomposition
1133	tl_mpp = mpp__init_file_cdf(tl_file)
1134	IF( ji == 1 )THEN
1135	tf_mpp=mpp_copy(tl_mpp)
1136	ELSE
1137	IF( ANY( tf_mpp%t_dim(1:2)%i_len /= &
1138	tl_mpp%t_dim(1:2)%i_len) )THEN
1139
1140	CALL logger_error("MPP INIT READ: dimension from file "//&
1141	& TRIM(tl_file%c_name)//" and mpp strcuture "//&
1142	& TRIM(tf_mpp%c_name)//"differ ")
1143
1144	ELSE
1145
1146	! add processor to mpp strcuture
1147	CALL mpp__add_proc(tf_mpp, tl_mpp%t_proc(1))
1148
1149	ENDIF
1150	ENDIF
1151
1152	! close file
1153	CALL iom_close(tl_file)
1154
1155	ENDDO
1156	IF( tf_mpp%i_nproc /= il_nproc )THEN
1157	CALL logger_error("MPP INIT READ: some processors can't be added &
1158	& to mpp structure")
1159	ENDIF
1160
1161	ELSE
1162
1163	! force to use domain decomposition to enhance read of input
1164
1165	! create pseudo mask
1166	il_dim(:)=tl_mpp%t_dim(:)%i_len
1167	ALLOCATE(il_mask(il_dim(jp_I),il_dim(jp_J)))
1168	il_mask(:,:)=1
1169
1170	! number of proc to get proc size close to im_psize
1171	il_niproc=INT(il_dim(jp_I)/im_psize)+1
1172	il_njproc=INT(il_dim(jp_J)/im_psize)+1
1173
1174	! compute domain layout
1175	! output will be written on one file
1176	tf_mpp=mpp_init(tl_mpp%c_name, il_mask, il_niproc, il_njproc,&
1177	& id_perio=tl_file%i_perio, &
1178	& ld_usempp=.FALSE. )
1179
1180	! add var
1181	DO ji=1,tl_mpp%t_proc(1)%i_nvar
1182	CALL mpp_add_var(tf_mpp, tl_mpp%t_proc(1)%t_var(ji))
1183	ENDDO
1184
1185	ENDIF
1186
1187	! mpp type
1188	tf_mpp%c_type=TRIM(td_file%c_type)
1189
1190	! mpp domain type
1191	CALL mpp_get_dom(tf_mpp)
1192
1193	! create some attributes for domain decomposition (use with dimg file)
1194	tl_att=att_init( "DOMAIN_number_total", tf_mpp%i_nproc )
1195	CALL mpp_move_att(tf_mpp, tl_att)
1196
1197	CALL mpp__compute_halo(tf_mpp)
1198
1199	! clean
1200	CALL mpp_clean(tl_mpp)
1201	CALL att_clean(tl_att)
1202
1203	CASE('dimg')
1204	! domain decomposition could be read in one file
1205
1206	tl_file=file_copy(td_file)
1207	! open file
1208	CALL logger_debug("MPP INIT READ: open file "//TRIM(tl_file%c_name))
1209	CALL iom_open(tl_file)
1210
1211	CALL logger_debug("MPP INIT READ: read mpp structure ")
1212	! read mpp structure
1213	tf_mpp=mpp__init_file_rstdimg(tl_file)
1214
1215	! mpp type
1216	tf_mpp%c_type=TRIM(td_file%c_type)
1217
1218	! mpp domain type
1219	CALL logger_debug("MPP INIT READ: mpp_get_dom ")
1220	CALL mpp_get_dom(tf_mpp)
1221
1222	! get processor size
1223	CALL logger_debug("MPP INIT READ: get processor size ")
1224	DO ji=1,tf_mpp%i_nproc
1225
1226	il_shape(:)=mpp_get_proc_size( tf_mpp, ji )
1227
1228	tl_dim=dim_init('X',il_shape(1))
1229	CALL file_add_dim(tf_mpp%t_proc(ji), tl_dim)
1230
1231	tl_dim=dim_init('Y',il_shape(2))
1232	CALL file_add_dim(tf_mpp%t_proc(ji), tl_dim)
1233
1234	! clean
1235	CALL dim_clean(tl_dim)
1236
1237	ENDDO
1238
1239	! close file
1240	CALL iom_close(tl_file)
1241
1242	CASE DEFAULT
1243	CALL logger_error("MPP INIT READ: invalid type for file "//&
1244	& TRIM(tl_file%c_name))
1245	END SELECT
1246
1247	! east west overlap
1248	IF( PRESENT(id_ew) ) tf_mpp%i_ew=id_ew
1249	! NEMO periodicity
1250	IF( PRESENT(id_perio) )THEN
1251	tf_mpp%i_perio= id_perio
1252	SELECT CASE(id_perio)
1253	CASE(3,4)
1254	tf_mpp%i_pivot=1
1255	CASE(5,6)
1256	tf_mpp%i_pivot=0
1257	CASE DEFAULT
1258	tf_mpp%i_pivot=1
1259	END SELECT
1260	ENDIF
1261
1262	IF( PRESENT(id_pivot) ) tf_mpp%i_pivot= id_pivot
1263
1264	! clean
1265	CALL file_clean(tl_file)
1266
1267	END FUNCTION mpp__init_file
1268	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1269	FUNCTION mpp__init_file_cdf(td_file) &
1270	& RESULT(tf_mpp)
1271	!-------------------------------------------------------------------
1272	!> @brief This function initalise a mpp structure,
1273	!> reading some netcdf files.
1274	!>
1275	!> @details
1276	!>
1277	!> @author J.Paul
1278	!> @date November, 2013 - Initial Version
1279	!> @date July, 2015
1280	!> - add only use dimension in MPP structure
1281	!> @date January, 2016
1282	!> - mismatch with "halo" indices, use mpp__read_halo
1283	!>
1284	!> @param[in] td_file file strcuture
1285	!> @return mpp structure
1286	!-------------------------------------------------------------------
1287
1288	IMPLICIT NONE
1289
1290	! Argument
1291	TYPE(TFILE), INTENT(IN) :: td_file
1292
1293	! function
1294	TYPE(TMPP) :: tf_mpp
1295
1296	! local variable
1297	INTEGER(i4) :: il_attid ! attribute id
1298
1299	LOGICAL :: ll_exist
1300	LOGICAL :: ll_open
1301
1302	TYPE(TATT) :: tl_att
1303
1304	TYPE(TDIM) :: tl_dim
1305
1306	TYPE(TFILE) :: tl_proc
1307	!----------------------------------------------------------------
1308
1309	CALL logger_trace("MPP INIT READ: netcdf file "//TRIM(td_file%c_name))
1310
1311	INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open )
1312	! ll_open do not work for netcdf file, return always FALSE
1313	IF( ll_exist )THEN
1314
1315	IF( td_file%i_id == 0 )THEN
1316	CALL logger_info(" id "//TRIM(fct_str(td_file%i_id)))
1317	CALL logger_error("MPP INIT READ: netcdf file "//&
1318	& TRIM(td_file%c_name)//" not opened")
1319	ELSE
1320
1321	! get mpp name
1322	tf_mpp%c_name=TRIM( file_rename(td_file%c_name) )
1323
1324	! add type
1325	tf_mpp%c_type="cdf"
1326
1327	! global domain size
1328	il_attid = 0
1329	IF( ASSOCIATED(td_file%t_att) )THEN
1330	il_attid=att_get_id( td_file%t_att, "DOMAIN_size_global" )
1331	ENDIF
1332	IF( il_attid /= 0 )THEN
1333	tl_dim=dim_init('X',INT(td_file%t_att(il_attid)%d_value(1)))
1334	CALL mpp_add_dim(tf_mpp,tl_dim)
1335
1336	tl_dim=dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2)))
1337	CALL mpp_add_dim(tf_mpp,tl_dim)
1338	ELSE ! assume only one file (not mpp)
1339	tl_dim=dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len)
1340	CALL mpp_add_dim(tf_mpp,tl_dim)
1341
1342	tl_dim=dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len)
1343	CALL mpp_add_dim(tf_mpp,tl_dim)
1344	ENDIF
1345
1346	IF( td_file%t_dim(3)%l_use )THEN
1347	tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len)
1348	CALL mpp_add_dim(tf_mpp,tl_dim)
1349	ENDIF
1350
1351	IF( td_file%t_dim(4)%l_use )THEN
1352	tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len)
1353	CALL mpp_add_dim(tf_mpp,tl_dim)
1354	ENDIF
1355
1356	! initialise file/processor
1357	tl_proc=file_copy(td_file)
1358
1359	! processor id
1360	il_attid = 0
1361	IF( ASSOCIATED(td_file%t_att) )THEN
1362	il_attid=att_get_id( td_file%t_att, "DOMAIN_number" )
1363	ENDIF
1364	IF( il_attid /= 0 )THEN
1365	tl_proc%i_pid = INT(td_file%t_att(il_attid)%d_value(1))
1366	ELSE
1367	tl_proc%i_pid = 1
1368	ENDIF
1369
1370	! processor dimension
1371	tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:))
1372
1373	CALL mpp__read_halo(tl_proc, tf_mpp%t_dim(:) )
1374
1375	! add attributes
1376	tl_att=att_init( "DOMAIN_size_global", tf_mpp%t_dim(:)%i_len)
1377	CALL file_move_att(tl_proc, tl_att)
1378
1379	tl_att=att_init( "DOMAIN_number", tl_proc%i_pid )
1380	CALL file_move_att(tl_proc, tl_att)
1381
1382	! add processor to mpp structure
1383	CALL mpp__add_proc(tf_mpp, tl_proc)
1384
1385	! clean
1386	CALL file_clean(tl_proc)
1387	CALL dim_clean(tl_dim)
1388	CALL att_clean(tl_att)
1389	ENDIF
1390
1391	ELSE
1392
1393	CALL logger_error("MPP INIT READ: netcdf file "//TRIM(td_file%c_name)//&
1394	& " do not exist")
1395
1396	ENDIF
1397
1398	END FUNCTION mpp__init_file_cdf
1399	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1400	FUNCTION mpp__init_file_rstdimg(td_file) &
1401	& RESULT(tf_mpp)
1402	!-------------------------------------------------------------------
1403	!> @brief This function initalise a mpp structure,
1404	!> reading one dimg restart file.
1405	!>
1406	!> @details
1407	!>
1408	!> @author J.Paul
1409	!> @date November, 2013 - Initial Version
1410	!> @date January, 2016
1411	!> - mismatch with "halo" indices, use mpp__compute_halo
1412	!> @date January,2019
1413	!> - clean file structure
1414	!>
1415	!> @param[in] td_file file strcuture
1416	!> @return mpp structure
1417	!-------------------------------------------------------------------
1418
1419	IMPLICIT NONE
1420
1421	! Argument
1422	TYPE(TFILE), INTENT(IN) :: td_file
1423
1424	! function
1425	TYPE(TMPP) :: tf_mpp
1426
1427	! local variable
1428	INTEGER(i4) :: il_status
1429	INTEGER(i4) :: il_recl ! record length
1430	INTEGER(i4) :: il_nx, il_ny, il_nz ! x,y,z dimension
1431	INTEGER(i4) :: il_n0d, il_n1d, il_n2d, il_n3d ! number of 0/1/2/3D variables
1432	INTEGER(i4) :: il_iglo, il_jglo ! domain global size
1433	INTEGER(i4) :: il_rhd ! record of the header infos
1434	INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition
1435	INTEGER(i4) :: il_area ! domain index
1436
1437	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci
1438	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi
1439	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei
1440	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp
1441	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj
1442	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj
1443	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej
1444	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp
1445
1446	LOGICAL :: ll_exist
1447	LOGICAL :: ll_open
1448
1449	CHARACTER(LEN=lc) :: cl_file
1450
1451	TYPE(TDIM) :: tl_dim ! dimension structure
1452	TYPE(TATT) :: tl_att
1453	TYPE(TFILE) :: tl_proc
1454
1455	! loop indices
1456	INTEGER(i4) :: ji
1457	!----------------------------------------------------------------
1458
1459	INQUIRE( FILE=TRIM(td_file%c_name), EXIST=ll_exist, OPENED=ll_open)
1460	IF( ll_exist )THEN
1461
1462	IF( .NOT. ll_open )THEN
1463	CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//&
1464	& " not opened")
1465	ELSE
1466
1467	! read first record
1468	READ( td_file%i_id, IOSTAT=il_status, REC=1 )&
1469	& il_recl, &
1470	& il_nx, il_ny, il_nz, &
1471	& il_n0d, il_n1d, il_n2d, il_n3d, &
1472	& il_rhd, &
1473	& il_pni, il_pnj, il_pnij, &
1474	& il_area
1475	CALL fct_err(il_status)
1476	IF( il_status /= 0 )THEN
1477	CALL logger_error("MPP INIT READ: read first line header of "//&
1478	& TRIM(td_file%c_name))
1479	ENDIF
1480
1481	! get mpp name
1482	tf_mpp%c_name=TRIM( file_rename(td_file%c_name) )
1483
1484	! add type
1485	tf_mpp%c_type="dimg"
1486
1487	! number of processors to be read
1488	tf_mpp%i_nproc = il_pnij
1489	tf_mpp%i_niproc = il_pni
1490	tf_mpp%i_njproc = il_pnj
1491
1492	IF( ASSOCIATED(tf_mpp%t_proc) )THEN
1493	CALL file_clean(tf_mpp%t_proc(:))
1494	DEALLOCATE(tf_mpp%t_proc)
1495	ENDIF
1496	ALLOCATE( tf_mpp%t_proc(il_pnij) , stat=il_status )
1497
1498	ALLOCATE(il_lci (il_pnij))
1499	ALLOCATE(il_lcj (il_pnij))
1500	ALLOCATE(il_ldi (il_pnij))
1501	ALLOCATE(il_ldj (il_pnij))
1502	ALLOCATE(il_lei (il_pnij))
1503	ALLOCATE(il_lej (il_pnij))
1504	ALLOCATE(il_impp(il_pnij))
1505	ALLOCATE(il_jmpp(il_pnij))
1506
1507	tl_proc=file_copy(td_file)
1508	! remove dimension from file
1509	CALL dim_clean(tl_proc%t_dim(:))
1510	! initialise file/processors
1511	DO ji=1,tf_mpp%i_nproc
1512	tf_mpp%t_proc(ji)=file_copy(tl_proc)
1513	ENDDO
1514
1515	IF( il_status /= 0 )THEN
1516	CALL logger_error("MPP INIT READ: not enough space to read domain &
1517	& decomposition in file "//TRIM(td_file%c_name))
1518	ENDIF
1519
1520	! read first record
1521	READ( td_file%i_id, IOSTAT=il_status, REC=1 )&
1522	& il_recl, &
1523	& il_nx, il_ny, il_nz, &
1524	& il_n0d, il_n1d, il_n2d, il_n3d, &
1525	& il_rhd, &
1526	& il_pni, il_pnj, il_pnij, &
1527	& il_area, &
1528	& il_iglo, il_jglo, &
1529	& il_lci(1:il_pnij), &
1530	& il_lcj(1:il_pnij), &
1531	& il_ldi(1:il_pnij), &
1532	& il_ldj(1:il_pnij), &
1533	& il_lei(1:il_pnij), &
1534	& il_lej(1:il_pnij), &
1535	& il_impp(1:il_pnij), &
1536	& il_jmpp(1:il_pnij)
1537	CALL fct_err(il_status)
1538	IF( il_status /= 0 )THEN
1539	CALL logger_error("MPP INIT READ: read first line of "//&
1540	& TRIM(td_file%c_name))
1541	ENDIF
1542
1543	tf_mpp%t_proc(1:il_pnij)%i_lci = il_lci (1:il_pnij)
1544	tf_mpp%t_proc(1:il_pnij)%i_lcj = il_lcj (1:il_pnij)
1545	tf_mpp%t_proc(1:il_pnij)%i_ldi = il_ldi (1:il_pnij)
1546	tf_mpp%t_proc(1:il_pnij)%i_ldj = il_ldj (1:il_pnij)
1547	tf_mpp%t_proc(1:il_pnij)%i_lei = il_lei (1:il_pnij)
1548	tf_mpp%t_proc(1:il_pnij)%i_lej = il_lej (1:il_pnij)
1549	tf_mpp%t_proc(1:il_pnij)%i_impp= il_impp(1:il_pnij)
1550	tf_mpp%t_proc(1:il_pnij)%i_jmpp= il_jmpp(1:il_pnij)
1551
1552	DEALLOCATE(il_lci)
1553	DEALLOCATE(il_lcj)
1554	DEALLOCATE(il_ldi)
1555	DEALLOCATE(il_ldj)
1556	DEALLOCATE(il_lei)
1557	DEALLOCATE(il_lej)
1558	DEALLOCATE(il_impp)
1559	DEALLOCATE(il_jmpp)
1560
1561	! global domain size
1562	tl_dim=dim_init('X',il_iglo)
1563	CALL mpp_add_dim(tf_mpp,tl_dim)
1564	tl_dim=dim_init('Y',il_jglo)
1565	CALL mpp_add_dim(tf_mpp,tl_dim)
1566
1567	tl_dim=dim_init('Z',il_nz)
1568	CALL mpp_add_dim(tf_mpp,tl_dim)
1569
1570	DO ji=1,tf_mpp%i_nproc
1571
1572	! get file name
1573	cl_file = file_rename(td_file%c_name,ji)
1574	tf_mpp%t_proc(ji)%c_name = TRIM(cl_file)
1575	! update processor id
1576	tf_mpp%t_proc(ji)%i_pid=ji
1577
1578	! add attributes
1579	tl_att=att_init( "DOMAIN_number", ji )
1580	CALL file_move_att(tf_mpp%t_proc(ji), tl_att)
1581
1582	ENDDO
1583
1584	! add type
1585	tf_mpp%t_proc(:)%c_type="dimg"
1586
1587	! add attributes
1588	tl_att=att_init("DOMAIN_size_global", tf_mpp%t_dim(:)%i_len)
1589	CALL mpp_move_att(tf_mpp, tl_att)
1590
1591	tl_att=att_init("DOMAIN_number_total", tf_mpp%i_nproc)
1592	CALL mpp_move_att(tf_mpp, tl_att)
1593
1594	tl_att=att_init("DOMAIN_I_number_total", tf_mpp%i_niproc)
1595	CALL mpp_move_att(tf_mpp, tl_att)
1596
1597	tl_att=att_init("DOMAIN_J_number_total", tf_mpp%i_njproc)
1598	CALL mpp_move_att(tf_mpp, tl_att)
1599
1600	CALL mpp_get_dom( tf_mpp )
1601
1602	CALL mpp__compute_halo( tf_mpp )
1603
1604	! clean
1605	CALL dim_clean(tl_dim)
1606	CALL att_clean(tl_att)
1607	CALL file_clean(tl_proc)
1608	ENDIF
1609
1610	ELSE
1611
1612	CALL logger_error("MPP INIT READ: dimg file "//TRIM(td_file%c_name)//&
1613	& " do not exist")
1614
1615	ENDIF
1616
1617	END FUNCTION mpp__init_file_rstdimg
1618	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1619	FUNCTION mpp__check_proc_dim(td_mpp, td_proc) &
1620	& RESULT(lf_check)
1621	!-------------------------------------------------------------------
1622	!> @brief This function check if variable and mpp structure use same
1623	!> dimension.
1624	!>
1625	!> @author J.Paul
1626	!> @date November, 2013 - Initial Version
1627	!>
1628	!> @param[in] td_mpp mpp structure
1629	!> @param[in] td_proc processor structure
1630	!> @return dimension of processor and mpp structure agree (or not)
1631	!-------------------------------------------------------------------
1632
1633	IMPLICIT NONE
1634
1635	! Argument
1636	TYPE(TMPP), INTENT(IN) :: td_mpp
1637	TYPE(TFILE), INTENT(IN) :: td_proc
1638
1639	!function
1640	LOGICAL :: lf_check
1641
1642	! local variable
1643	INTEGER(i4) :: il_isize !< i-direction maximum sub domain size
1644	INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size
1645	!----------------------------------------------------------------
1646
1647	lf_check=.TRUE.
1648	! check used dimension
1649	IF( td_mpp%i_niproc /= 0 .AND. td_mpp%i_njproc /= 0 )THEN
1650	! check with maximum size of sub domain
1651	il_isize = ( td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + &
1652	& (td_mpp%i_niproc-1) ) / td_mpp%i_niproc + 2*td_mpp%i_preci
1653	il_jsize = ( td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + &
1654	& (td_mpp%i_njproc-1) ) / td_mpp%i_njproc + 2*td_mpp%i_precj
1655
1656	IF( il_isize < td_proc%i_lci .OR. &
1657	&il_jsize < td_proc%i_lcj )THEN
1658
1659	lf_check=.FALSE.
1660
1661	CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" )
1662
1663	ENDIF
1664
1665	ELSE
1666	! check with global domain size
1667	IF( td_mpp%t_dim(1)%i_len < td_proc%i_lci .OR. &
1668	&td_mpp%t_dim(2)%i_len < td_proc%i_lcj )THEN
1669
1670	lf_check=.FALSE.
1671
1672	CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" )
1673
1674	ENDIF
1675	ENDIF
1676
1677	END FUNCTION mpp__check_proc_dim
1678	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1679	SUBROUTINE mpp_add_var(td_mpp, td_var)
1680	!-------------------------------------------------------------------
1681	!> @brief
1682	!> This subroutine add variable in all files of mpp structure.
1683	!>
1684	!> @author J.Paul
1685	!> @date November, 2013 - Initial version
1686	!> @date January, 2019
1687	!> - do not split variable on domain decomposition, if only one procesor
1688	!>
1689	!> @param[inout] td_mpp mpp strcuture
1690	!> @param[in] td_var variable strcuture
1691	!-------------------------------------------------------------------
1692
1693	IMPLICIT NONE
1694
1695	! Argument
1696	TYPE(TMPP), INTENT(INOUT) :: td_mpp
1697	TYPE(TVAR), INTENT(INOUT) :: td_var
1698
1699	! local variable
1700	INTEGER(i4) :: il_varid
1701	TYPE(TVAR) :: tl_var
1702
1703	! loop indices
1704	INTEGER(i4) :: ji
1705	!----------------------------------------------------------------
1706
1707	! check if mpp exist
1708	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
1709
1710	CALL logger_error( "MPP ADD VAR: processor decomposition not "//&
1711	& "define for mpp "//TRIM(td_mpp%c_name))
1712
1713	ELSE
1714	! check if variable exist
1715	IF( TRIM(td_var%c_name) == '' .AND. &
1716	& TRIM(td_var%c_stdname) == '' )THEN
1717	CALL logger_error("MPP ADD VAR: variable not define ")
1718	ELSE
1719	! check if variable already in mpp structure
1720	il_varid=0
1721	IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
1722	il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
1723	& td_var%c_name, td_var%c_stdname )
1724	ENDIF
1725
1726	IF( il_varid /= 0 )THEN
1727
1728	DO ji=1,td_mpp%t_proc(1)%i_nvar
1729	CALL logger_debug( " MPP ADD VAR: in mpp structure : &
1730	& variable "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//&
1731	& ", standard name "//&
1732	& TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) )
1733	ENDDO
1734	CALL logger_error( " MPP ADD VAR: variable "//TRIM(td_var%c_name)//&
1735	& ", standard name "//TRIM(td_var%c_stdname)//&
1736	& ", already in mpp "//TRIM(td_mpp%c_name) )
1737
1738	ELSE
1739
1740	CALL logger_info( &
1741	& " MPP ADD VAR: add variable "//TRIM(td_var%c_name)//&
1742	& ", standard name "//TRIM(td_var%c_stdname)//&
1743	& ", in mpp "//TRIM(td_mpp%c_name) )
1744	! check used dimension
1745	IF( mpp__check_dim(td_mpp, td_var) )THEN
1746
1747	! check variable dimension expected
1748	CALL var_check_dim(td_var)
1749
1750	! update dimension if need be
1751	DO ji=1,ip_maxdim
1752	IF( td_var%t_dim(ji)%l_use .AND. &
1753	& .NOT. td_mpp%t_dim(ji)%l_use )THEN
1754	CALL mpp_add_dim(td_mpp,td_var%t_dim(ji))
1755	ENDIF
1756	ENDDO
1757
1758	! add variable in each processor
1759	IF( td_mpp%i_nproc == 1 )THEN
1760	CALL file_add_var(td_mpp%t_proc(1), td_var)
1761	ELSE
1762	DO ji=1,td_mpp%i_nproc
1763	! split variable on domain decomposition
1764	tl_var=mpp__split_var(td_mpp, td_var, ji)
1765
1766	CALL file_add_var(td_mpp%t_proc(ji), tl_var)
1767
1768	! clean
1769	CALL var_clean(tl_var)
1770	ENDDO
1771	ENDIF
1772
1773	ENDIF
1774	ENDIF
1775	ENDIF
1776	ENDIF
1777
1778	END SUBROUTINE mpp_add_var
1779	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1780	FUNCTION mpp__split_var(td_mpp, td_var, id_procid) &
1781	& RESULT(tf_var)
1782	!-------------------------------------------------------------------
1783	!> @brief This function extract, from variable structure, part that will
1784	!> be written in processor id_procid.<br/>
1785	!>
1786	!> @author J.Paul
1787	!> @date November, 2013 - Initial Version
1788	!>
1789	!> @param[in] td_mpp mpp structure
1790	!> @param[in] td_var variable structure
1791	!> @param[in] id_procid processor id
1792	!> @return variable structure
1793	!-------------------------------------------------------------------
1794
1795	IMPLICIT NONE
1796
1797	! Argument
1798	TYPE(TMPP), INTENT(IN) :: td_mpp
1799	TYPE(TVAR), INTENT(IN) :: td_var
1800	INTEGER(i4), INTENT(IN) :: id_procid
1801
1802	! function
1803	TYPE(TVAR) :: tf_var
1804
1805	! local variable
1806	TYPE(TDIM) :: tl_dim
1807
1808	INTEGER(i4), DIMENSION(4) :: il_ind
1809	INTEGER(i4), DIMENSION(2) :: il_size
1810	INTEGER(i4) :: il_i1
1811	INTEGER(i4) :: il_i2
1812	INTEGER(i4) :: il_j1
1813	INTEGER(i4) :: il_j2
1814	!----------------------------------------------------------------
1815
1816	! copy mpp
1817	tf_var=var_copy(td_var, ld_value=.FALSE.)
1818
1819	! get processor indices
1820	il_ind(:)=mpp_get_proc_index( td_mpp, id_procid )
1821	il_i1 = il_ind(1)
1822	il_i2 = il_ind(2)
1823	il_j1 = il_ind(3)
1824	il_j2 = il_ind(4)
1825
1826	IF( .NOT. td_var%t_dim(1)%l_use )THEN
1827	il_i1=1
1828	il_i2=1
1829	ENDIF
1830
1831	IF( .NOT. td_var%t_dim(2)%l_use )THEN
1832	il_j1=1
1833	il_j2=1
1834	ENDIF
1835
1836	IF( ASSOCIATED(td_var%d_value) )THEN
1837	! remove value over global domain from pointer
1838	!CALL var_del_value( tf_var )
1839
1840	! get processor dimension
1841	il_size(:)=mpp_get_proc_size( td_mpp, id_procid )
1842
1843	! define new dimension in variable structure
1844	IF( td_var%t_dim(1)%l_use )THEN
1845	tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) )
1846	CALL var_move_dim( tf_var, tl_dim )
1847	ENDIF
1848	IF( td_var%t_dim(2)%l_use )THEN
1849	tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) )
1850	CALL var_move_dim( tf_var, tl_dim )
1851	ENDIF
1852
1853	! add variable value on processor
1854	CALL var_add_value( tf_var, &
1855	& td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) )
1856
1857	ELSE
1858
1859	tf_var%t_dim(jp_I)%i_len=il_i2-il_i1+1
1860	tf_var%t_dim(jp_J)%i_len=il_j2-il_j1+1
1861
1862	ENDIF
1863
1864	END FUNCTION mpp__split_var
1865	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1866	SUBROUTINE mpp__del_var_mpp(td_mpp)
1867	!-------------------------------------------------------------------
1868	!> @brief
1869	!> This subroutine delete all variable in mpp strcuture.
1870	!>
1871	!> @author J.Paul
1872	!> @date October, 2014 - Initial version
1873	!>
1874	!> @param[inout] td_mpp mpp strcuture
1875	!-------------------------------------------------------------------
1876
1877	IMPLICIT NONE
1878
1879	! Argument
1880	TYPE(TMPP), INTENT(INOUT) :: td_mpp
1881
1882	! local variable
1883	! loop indices
1884	INTEGER(i4) :: ji
1885	!----------------------------------------------------------------
1886
1887	CALL logger_info( &
1888	& "MPP CLEAN VAR: reset all variable "//&
1889	& "in mpp strcuture "//TRIM(td_mpp%c_name) )
1890
1891	IF( ASSOCIATED(td_mpp%t_proc) )THEN
1892	DO ji=td_mpp%t_proc(1)%i_nvar,1,-1
1893	CALL mpp_del_var(td_mpp, td_mpp%t_proc(1)%t_var(ji))
1894	ENDDO
1895	ENDIF
1896
1897	END SUBROUTINE mpp__del_var_mpp
1898	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1899	SUBROUTINE mpp__del_var_str(td_mpp, td_var)
1900	!-------------------------------------------------------------------
1901	!> @brief
1902	!> This subroutine delete variable in mpp structure, given variable
1903	!> structure.
1904	!>
1905	!> @author J.Paul
1906	!> @date November, 2013 - Initial version
1907	!>
1908	!> @param[inout] td_mpp mpp strcuture
1909	!> @param[in] td_var variable strcuture
1910	!-------------------------------------------------------------------
1911
1912	IMPLICIT NONE
1913
1914	! Argument
1915	TYPE(TMPP), INTENT(INOUT) :: td_mpp
1916	TYPE(TVAR), INTENT(IN) :: td_var
1917
1918	! local variable
1919	INTEGER(i4) :: il_varid
1920	CHARACTER(LEN=lc) :: cl_name
1921
1922	! loop indices
1923	INTEGER(i4) :: ji
1924	!----------------------------------------------------------------
1925
1926	! check if mpp exist
1927	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
1928
1929	CALL logger_error( "MPP DEL VAR: domain decomposition not define "//&
1930	& " in mpp strcuture "//TRIM(td_mpp%c_name))
1931
1932	ELSE
1933
1934	! check if variable already in mpp structure
1935	il_varid = 0
1936	IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
1937	il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
1938	& td_var%c_name, td_var%c_stdname )
1939	ENDIF
1940	IF( il_varid == 0 )THEN
1941	CALL logger_error( &
1942	& "MPP DEL VAR: no variable "//TRIM(td_var%c_name)//&
1943	& ", in mpp structure "//TRIM(td_mpp%c_name) )
1944
1945	DO ji=1,td_mpp%t_proc(1)%i_nvar
1946	CALL logger_debug( "MPP DEL VAR: in mpp structure : &
1947	& variable : "//TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name)//&
1948	& ", standard name "//&
1949	& TRIM(td_mpp%t_proc(1)%t_var(ji)%c_stdname) )
1950	ENDDO
1951
1952	ELSE
1953
1954	cl_name=TRIM(td_var%c_name)
1955	DO ji=1,td_mpp%i_nproc
1956	CALL file_del_var(td_mpp%t_proc(ji), TRIM(cl_name))
1957	ENDDO
1958
1959	ENDIF
1960	ENDIF
1961
1962	END SUBROUTINE mpp__del_var_str
1963	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1964	SUBROUTINE mpp__del_var_name(td_mpp, cd_name)
1965	!-------------------------------------------------------------------
1966	!> @brief
1967	!> This subroutine delete variable in mpp structure, given variable name.
1968	!>
1969	!> @author J.Paul
1970	!> @date November, 2013 - Initial version
1971	!> @date February, 2015
1972	!> - define local variable structure to avoid mistake with pointer
1973	!> @date January, 2019
1974	!> - clean variable strcuture
1975	!>
1976	!> @param[inout] td_mpp mpp strcuture
1977	!> @param[in] cd_name variable name
1978	!-------------------------------------------------------------------
1979
1980	IMPLICIT NONE
1981
1982	! Argument
1983	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
1984	CHARACTER(LEN=*), INTENT(IN ) :: cd_name
1985
1986	! local variable
1987	INTEGER(i4) :: il_varid
1988	TYPE(TVAR) :: tl_var
1989	!----------------------------------------------------------------
1990
1991	! check if mpp exist
1992	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
1993
1994	CALL logger_error( "MPP DEL VAR: domain decomposition not define "//&
1995	& " in mpp strcuture "//TRIM(td_mpp%c_name))
1996
1997	ELSE
1998
1999	IF( td_mpp%t_proc(1)%i_nvar == 0 )THEN
2000	CALL logger_debug( "MPP DEL VAR NAME: no variable associated to mpp &
2001	& structure "//TRIM(td_mpp%c_name) )
2002	ELSE
2003
2004	! get the variable id, in file variable structure
2005	il_varid=0
2006	IF( ASSOCIATED(td_mpp%t_proc(1)%t_var) )THEN
2007	il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), &
2008	& cd_name )
2009	ENDIF
2010
2011	IF( il_varid == 0 )THEN
2012
2013	CALL logger_warn( &
2014	& "MPP DEL VAR : there is no variable with name "//&
2015	& "or standard name "//TRIM(ADJUSTL(cd_name))//&
2016	& " in mpp structure "//TRIM(td_mpp%c_name))
2017
2018	ELSE
2019
2020	tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid))
2021	CALL mpp_del_var(td_mpp, tl_var)
2022	! clean
2023	CALL var_clean(tl_var)
2024	ENDIF
2025	ENDIF
2026	ENDIF
2027
2028	END SUBROUTINE mpp__del_var_name
2029	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2030	SUBROUTINE mpp_move_var(td_mpp, td_var)
2031	!-------------------------------------------------------------------
2032	!> @brief
2033	!> This subroutine overwrite variable in mpp structure.
2034	!>
2035	!> @author J.Paul
2036	!> @date November, 2013 - Initial version
2037	!>
2038	!> @param[inout] td_mpp mpp strcuture
2039	!> @param[in] td_var variable structure
2040	!-------------------------------------------------------------------
2041
2042	IMPLICIT NONE
2043
2044	! Argument
2045	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2046	TYPE(TVAR), INTENT(IN) :: td_var
2047
2048	!local variable
2049	TYPE(TVAR) :: tl_var
2050	!----------------------------------------------------------------
2051
2052	! copy variablie
2053	tl_var=var_copy(td_var)
2054
2055	! remove processor
2056	CALL mpp_del_var(td_mpp, tl_var)
2057
2058	! add processor
2059	CALL mpp_add_var(td_mpp, tl_var)
2060
2061	! clean
2062	CALL var_clean(tl_var)
2063
2064	END SUBROUTINE mpp_move_var
2065	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2066	SUBROUTINE mpp__add_proc_unit(td_mpp, td_proc)
2067	!-------------------------------------------------------------------
2068	!> @brief
2069	!> This subroutine add processor to mpp structure.
2070	!>
2071	!> @author J.Paul
2072	!> @date November, 2013 - Initial version
2073	!> @date January, 2019
2074	!> - deallocate file structure whatever happens
2075	!> @date July, 2020
2076	!> - look for array index of proc id, only if proc id contains in array
2077	!>
2078	!> @param[inout] td_mpp mpp strcuture
2079	!> @param[in] td_proc processor strcuture
2080	!-------------------------------------------------------------------
2081
2082	IMPLICIT NONE
2083
2084	! Argument
2085	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
2086	TYPE(TFILE), INTENT(IN) :: td_proc
2087
2088	! local variable
2089	INTEGER(i4) :: il_status
2090	INTEGER(i4) :: il_procid
2091	INTEGER(i4) , DIMENSION(1) :: il_ind
2092
2093	TYPE(TFILE) , DIMENSION(:), ALLOCATABLE :: tl_proc
2094
2095	LOGICAL , DIMENSION(:), ALLOCATABLE :: ll_mask
2096
2097	CHARACTER(LEN=lc) :: cl_name
2098	!----------------------------------------------------------------
2099
2100	! check file name
2101	cl_name=TRIM( file_rename(td_proc%c_name) )
2102	IF( TRIM(cl_name) /= TRIM(td_mpp%c_name) )THEN
2103	CALL logger_warn("MPP ADD PROC: processor name do not match mpp name")
2104	ENDIF
2105
2106	il_procid=0
2107	IF( ASSOCIATED(td_mpp%t_proc) )THEN
2108	! check if processor already in mpp structure
2109	ALLOCATE(ll_mask(SIZE(td_mpp%t_proc(:))))
2110	ll_mask(:)=(td_mpp%t_proc(:)%i_pid==td_proc%i_pid)
2111	IF( ANY(ll_mask(:)) )THEN
2112	il_ind(:)=MINLOC( td_mpp%t_proc(:)%i_pid, mask=ll_mask(:) )
2113	il_procid=il_ind(1)
2114	ENDIF
2115	DEALLOCATE(ll_mask)
2116	ENDIF
2117
2118	IF( il_procid /= 0 )THEN
2119
2120	CALL logger_error( &
2121	& "MPP ADD PROC: processor "//TRIM(fct_str(td_proc%i_pid))//&
2122	& ", already in mpp structure " )
2123
2124	ELSE
2125
2126	CALL logger_trace("MPP ADD PROC: add processor "//&
2127	& TRIM(fct_str(td_mpp%i_nproc+1))//" in mpp structure")
2128
2129	IF( td_mpp%i_nproc > 0 )THEN
2130	!
2131	il_ind(:)=MAXLOC( td_mpp%t_proc(:)%i_pid, &
2132	mask=(td_mpp%t_proc(:)%i_pid < td_proc%i_pid) )
2133	il_procid=il_ind(1)
2134
2135	! already other processor in mpp structure
2136	ALLOCATE( tl_proc(td_mpp%i_nproc), stat=il_status )
2137	IF(il_status /= 0 )THEN
2138
2139	CALL logger_error( "MPP ADD PROC: not enough space to put processor &
2140	& in mpp structure")
2141
2142	ELSE
2143	! save temporary mpp structure
2144	tl_proc(:)=file_copy(td_mpp%t_proc(:))
2145
2146	CALL file_clean( td_mpp%t_proc(:) )
2147	DEALLOCATE(td_mpp%t_proc)
2148	ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status)
2149	IF(il_status /= 0 )THEN
2150
2151	CALL logger_error( "MPP ADD PROC: not enough space to put "//&
2152	& "processor in mpp structure ")
2153
2154	ENDIF
2155
2156	! copy processor in mpp before
2157	! processor with lower id than new processor
2158	td_mpp%t_proc( 1:il_procid ) = file_copy(tl_proc( 1:il_procid ))
2159
2160	! processor with greater id than new processor
2161	td_mpp%t_proc( il_procid+1 : td_mpp%i_nproc+1 ) = &
2162	& file_copy(tl_proc( il_procid : td_mpp%i_nproc ))
2163
2164	! clean
2165	CALL file_clean(tl_proc(:))
2166	ENDIF
2167	DEALLOCATE(tl_proc)
2168
2169	ELSE
2170
2171	! no processor in mpp structure
2172	IF( ASSOCIATED(td_mpp%t_proc) )THEN
2173	CALL file_clean(td_mpp%t_proc(:))
2174	DEALLOCATE(td_mpp%t_proc)
2175	ENDIF
2176	ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc+1), stat=il_status )
2177	IF(il_status /= 0 )THEN
2178
2179	CALL logger_error( "MPP ADD PROC: not enough space to put "//&
2180	& "processor in mpp structure " )
2181
2182	ENDIF
2183	ENDIF
2184
2185	! check dimension
2186	IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc%t_dim(1:2)%i_len) )THEN
2187	CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//&
2188	& " dimension differ. ")
2189	CALL logger_debug("MPP ADD PROC: mpp dimension ("//&
2190	& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
2191	& TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" )
2192	CALL logger_debug("MPP ADD PROC: processor dimension ("//&
2193	& TRIM(fct_str(td_proc%t_dim(1)%i_len))//","//&
2194	& TRIM(fct_str(td_proc%t_dim(2)%i_len))//")" )
2195	ELSE
2196	td_mpp%i_nproc=td_mpp%i_nproc+1
2197
2198	! add new processor
2199	td_mpp%t_proc(td_mpp%i_nproc)=file_copy(td_proc)
2200	ENDIF
2201
2202	ENDIF
2203
2204	END SUBROUTINE mpp__add_proc_unit
2205	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2206	SUBROUTINE mpp__add_proc_arr(td_mpp, td_proc)
2207	!-------------------------------------------------------------------
2208	!> @brief
2209	!> This subroutine add array of processor to mpp structure.
2210	!> @note mpp structure should be empty
2211	!>
2212	!> @author J.Paul
2213	!> @date August, 2017 - Initial version
2214	!>
2215	!> @param[inout] td_mpp mpp strcuture
2216	!> @param[in] td_proc array of processor strcuture
2217	!-------------------------------------------------------------------
2218
2219	IMPLICIT NONE
2220
2221	! Argument
2222	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
2223	TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_proc
2224
2225	! local variable
2226	INTEGER(i4) :: il_status
2227	INTEGER(i4) :: il_nproc
2228
2229	CHARACTER(LEN=lc) :: cl_name
2230	!----------------------------------------------------------------
2231
2232	! check file name
2233	cl_name=TRIM( file_rename(td_proc(1)%c_name) )
2234	IF( TRIM(cl_name) /= TRIM(td_mpp%c_name) )THEN
2235	CALL logger_warn("MPP ADD PROC: processor name do not match mpp name")
2236	ENDIF
2237
2238	IF( ASSOCIATED(td_mpp%t_proc) )THEN
2239	CALL logger_error( &
2240	& "MPP ADD PROC: some processor(s) already in mpp structure " )
2241
2242	ELSE
2243
2244	CALL logger_trace("MPP ADD PROC: add array of processor "//&
2245	& " in mpp structure")
2246
2247	il_nproc=SIZE(td_proc)
2248	ALLOCATE( td_mpp%t_proc(il_nproc), stat=il_status )
2249	IF(il_status /= 0 )THEN
2250	CALL logger_error( "MPP ADD PROC: not enough space to put "//&
2251	& "processor in mpp structure " )
2252	ENDIF
2253
2254	! check dimension
2255	IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc(1)%t_dim(1:2)%i_len) )THEN
2256	CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//&
2257	& " dimension differ. ")
2258	CALL logger_debug("MPP ADD PROC: mpp dimension ("//&
2259	& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
2260	& TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" )
2261	CALL logger_debug("MPP ADD PROC: processor dimension ("//&
2262	& TRIM(fct_str(td_proc(1)%t_dim(1)%i_len))//","//&
2263	& TRIM(fct_str(td_proc(1)%t_dim(2)%i_len))//")" )
2264	ELSE
2265	td_mpp%i_nproc=il_nproc
2266
2267	! add new processor
2268	td_mpp%t_proc(:)=file_copy(td_proc(:))
2269	ENDIF
2270
2271	ENDIF
2272
2273	END SUBROUTINE mpp__add_proc_arr
2274	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2275	SUBROUTINE mpp__del_proc_id(td_mpp, id_procid)
2276	!-------------------------------------------------------------------
2277	!> @brief
2278	!> This subroutine delete processor in mpp structure, given processor id.
2279	!>
2280	!> @author J.Paul
2281	!> @date November, 2013 - Initial version
2282	!> @date January, 2019
2283	!> - clean file structure
2284	!>
2285	!> @param[inout] td_mpp mpp strcuture
2286	!> @param[in] id_procid processor id
2287	!-------------------------------------------------------------------
2288
2289	IMPLICIT NONE
2290
2291	! Argument
2292	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2293	INTEGER(i4), INTENT(IN) :: id_procid
2294
2295	! local variable
2296	INTEGER(i4) :: il_status
2297	INTEGER(i4) :: il_procid
2298	INTEGER(i4), DIMENSION(1) :: il_ind
2299	TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc
2300
2301	! loop indices
2302	!----------------------------------------------------------------
2303
2304	il_ind(:)=MINLOC(td_mpp%t_proc(:)%i_pid,td_mpp%t_proc(:)%i_pid==id_procid)
2305	il_procid=il_ind(1)
2306	IF( il_procid == 0 )THEN
2307	CALL logger_error("MPP DEL PROC: no processor "//&
2308	& TRIM(fct_str(id_procid))//&
2309	& " associated to mpp structure")
2310	ELSE
2311	CALL logger_trace("DEL PROC: remove processor "//&
2312	& TRIM(fct_str(id_procid)))
2313
2314	IF( td_mpp%i_nproc > 1 )THEN
2315	ALLOCATE( tl_proc(td_mpp%i_nproc-1), stat=il_status )
2316	IF(il_status /= 0 )THEN
2317	CALL logger_error( "MPP DEL PROC: not enough space to put &
2318	& processor in temporary mpp structure")
2319
2320	ELSE
2321
2322	! save temporary processor's mpp structure
2323	IF( il_procid > 1 )THEN
2324	tl_proc(1:il_procid-1)=file_copy(td_mpp%t_proc(1:il_procid-1))
2325	ENDIF
2326
2327	IF( il_procid < td_mpp%i_nproc )THEN
2328	tl_proc(il_procid:)=file_copy(td_mpp%t_proc(il_procid+1:))
2329	ENDIF
2330
2331	! new number of processor in mpp
2332	td_mpp%i_nproc=td_mpp%i_nproc-1
2333
2334	CALL file_clean( td_mpp%t_proc(:) )
2335	DEALLOCATE(td_mpp%t_proc)
2336	ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc), stat=il_status )
2337	IF(il_status /= 0 )THEN
2338
2339	CALL logger_error( "MPP DEL PROC: not enough space &
2340	& to put processors in mpp structure " )
2341
2342	ELSE
2343
2344	! copy processor in mpp before
2345	td_mpp%t_proc(:)=file_copy(tl_proc(:))
2346
2347	! update processor id
2348	td_mpp%t_proc( il_procid : td_mpp%i_nproc )%i_pid = &
2349	& td_mpp%t_proc( il_procid : td_mpp%i_nproc )%i_pid - 1
2350
2351	ENDIF
2352	ENDIF
2353	! clean
2354	CALL file_clean( tl_proc(:) )
2355	DEALLOCATE(tl_proc)
2356	ELSE
2357	CALL file_clean( td_mpp%t_proc(:) )
2358	DEALLOCATE(td_mpp%t_proc)
2359
2360	! new number of processor in mpp
2361	td_mpp%i_nproc=td_mpp%i_nproc-1
2362	ENDIF
2363	ENDIF
2364
2365	END SUBROUTINE mpp__del_proc_id
2366	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2367	SUBROUTINE mpp__del_proc_str(td_mpp, td_proc)
2368	!-------------------------------------------------------------------
2369	!> @brief
2370	!> This subroutine delete processor in mpp structure, given processor
2371	!> structure.
2372	!>
2373	!> @author J.Paul
2374	!> @date November, 2013 - Initial version
2375	!>
2376	!> @param[inout] td_mpp : mpp strcuture
2377	!> @param[in] td_proc : file/processor structure
2378	!-------------------------------------------------------------------
2379
2380	IMPLICIT NONE
2381
2382	! Argument
2383	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2384	TYPE(TFILE), INTENT(IN) :: td_proc
2385	!----------------------------------------------------------------
2386
2387	IF( td_proc%i_pid >= 0 )THEN
2388	CALL mpp__del_proc( td_mpp, td_proc%i_pid )
2389	ELSE
2390	CALL logger_error("MPP DEL PROC: processor not defined")
2391	ENDIF
2392
2393	END SUBROUTINE mpp__del_proc_str
2394	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2395	SUBROUTINE mpp__move_proc(td_mpp, td_proc)
2396	!-------------------------------------------------------------------
2397	!> @brief
2398	!> This subroutine overwrite processor in mpp structure.
2399	!>
2400	!> @detail
2401	!>
2402	!> @author J.Paul
2403	!> @date Nov, 2013 - Initial version
2404	!>
2405	!> @param[inout] td_mpp mpp strcuture
2406	!> @param[in] id_procid processor id
2407	!-------------------------------------------------------------------
2408
2409	IMPLICIT NONE
2410
2411	! Argument
2412	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2413	TYPE(TFILE), INTENT(IN) :: td_proc
2414	!----------------------------------------------------------------
2415
2416	! remove processor
2417	CALL mpp__del_proc(td_mpp, td_proc)
2418
2419	! add processor
2420	CALL mpp__add_proc(td_mpp, td_proc)
2421
2422	END SUBROUTINE mpp__move_proc
2423	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2424	SUBROUTINE mpp_add_dim(td_mpp, td_dim)
2425	!-------------------------------------------------------------------
2426	!> @brief This subroutine add a dimension structure in a mpp
2427	!> structure.
2428	!> Do not overwrite, if dimension already in mpp structure.
2429	!>
2430	!> @author J.Paul
2431	!> @date November, 2013 - Initial Version
2432	!> @date July, 2015
2433	!> - rewrite the same as way var_add_dim
2434	!>
2435	!> @param[inout] td_mpp mpp structure
2436	!> @param[in] td_dim dimension structure
2437	!-------------------------------------------------------------------
2438
2439	IMPLICIT NONE
2440
2441	! Argument
2442	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2443	TYPE(TDIM), INTENT(IN) :: td_dim
2444
2445	! local variable
2446	INTEGER(i4) :: il_ind
2447
2448	! loop indices
2449	!----------------------------------------------------------------
2450
2451	IF( td_mpp%i_ndim <= ip_maxdim )THEN
2452
2453	! check if dimension already used in mpp structure
2454	il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname))
2455	IF( il_ind == 0 )THEN
2456	CALL logger_warn( &
2457	& " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//&
2458	& ", short name "//TRIM(td_dim%c_sname)//&
2459	& ", will not be added in mpp "//TRIM(td_mpp%c_name) )
2460	ELSEIF( td_mpp%t_dim(il_ind)%l_use )THEN
2461	CALL logger_error( &
2462	& " MPP ADD DIM: dimension "//TRIM(td_dim%c_name)//&
2463	& ", short name "//TRIM(td_dim%c_sname)//&
2464	& ", already used in mpp "//TRIM(td_mpp%c_name) )
2465	ELSE
2466
2467	! back to disorder dimension array
2468	CALL dim_disorder(td_mpp%t_dim(:))
2469
2470	! add new dimension
2471	td_mpp%t_dim(td_mpp%i_ndim+1)=dim_copy(td_dim)
2472
2473	! update number of attribute
2474	td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use)
2475
2476	ENDIF
2477	! reorder dimension to ('x','y','z','t')
2478	CALL dim_reorder(td_mpp%t_dim(:))
2479
2480	ELSE
2481	CALL logger_error( &
2482	& "MPP ADD DIM: too much dimension in mpp "//&
2483	& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
2484	ENDIF
2485
2486	END SUBROUTINE mpp_add_dim
2487	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2488	SUBROUTINE mpp_del_dim(td_mpp, td_dim)
2489	!-------------------------------------------------------------------
2490	!> @brief This subroutine delete a dimension structure in a mpp
2491	!> structure.<br/>
2492	!>
2493	!> @author J.Paul
2494	!> @date November, 2013 - Initial Version
2495	!> @date July, 2015
2496	!> - rewrite the same as way var_del_dim
2497	!>
2498	!> @param[inout] td_mpp mpp structure
2499	!> @param[in] td_dim dimension structure
2500	!-------------------------------------------------------------------
2501
2502	IMPLICIT NONE
2503
2504	! Argument
2505	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2506	TYPE(TDIM), INTENT(IN) :: td_dim
2507
2508	! local variable
2509	INTEGER(i4) :: il_ind
2510	TYPE(TDIM) :: tl_dim
2511
2512	! loop indices
2513	!----------------------------------------------------------------
2514
2515	IF( td_mpp%i_ndim <= ip_maxdim )THEN
2516
2517	CALL logger_trace( &
2518	& " MPP DEL DIM: delete dimension "//TRIM(td_dim%c_name)//&
2519	& ", short name "//TRIM(td_dim%c_sname)//&
2520	& ", in mpp "//TRIM(td_mpp%c_name) )
2521
2522	! check if dimension already in variable structure
2523	il_ind=SCAN(TRIM(cp_dimorder),TRIM(td_dim%c_sname))
2524
2525	! replace dimension by empty one
2526	td_mpp%t_dim(il_ind)=dim_copy(tl_dim)
2527
2528	! update number of dimension
2529	td_mpp%i_ndim=COUNT(td_mpp%t_dim(:)%l_use)
2530
2531	! reorder dimension to ('x','y','z','t')
2532	CALL dim_reorder(td_mpp%t_dim)
2533
2534	ELSE
2535	CALL logger_error( &
2536	& " MPP DEL DIM: too much dimension in mpp "//&
2537	& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
2538	ENDIF
2539
2540	END SUBROUTINE mpp_del_dim
2541	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2542	SUBROUTINE mpp_move_dim(td_mpp, td_dim)
2543	!-------------------------------------------------------------------
2544	!> @brief This subroutine move a dimension structure
2545	!> in mpp structure.
2546	!> @warning dimension order may have changed
2547	!>
2548	!> @author J.Paul
2549	!> @date November, 2013 - Initial Version
2550	!>
2551	!> @param[inout] td_mpp mpp structure
2552	!> @param[in] td_dim dimension structure
2553	!-------------------------------------------------------------------
2554
2555	IMPLICIT NONE
2556
2557	! Argument
2558	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2559	TYPE(TDIM), INTENT(IN) :: td_dim
2560
2561	! local variable
2562	INTEGER(i4) :: il_ind
2563	INTEGER(i4) :: il_dimid
2564	!----------------------------------------------------------------
2565
2566	IF( td_mpp%i_ndim <= ip_maxdim )THEN
2567
2568	! check if dimension already in mpp structure
2569	il_ind=dim_get_index(td_mpp%t_dim(:), td_dim%c_name, td_dim%c_sname)
2570	IF( il_ind /= 0 )THEN
2571
2572	il_dimid=td_mpp%t_dim(il_ind)%i_id
2573	! replace dimension
2574	td_mpp%t_dim(il_ind)=dim_copy(td_dim)
2575	td_mpp%t_dim(il_ind)%i_id=il_dimid
2576	td_mpp%t_dim(il_ind)%l_use=.TRUE.
2577
2578	ELSE
2579	CALL mpp_add_dim(td_mpp, td_dim)
2580	ENDIF
2581
2582	ELSE
2583	CALL logger_error( &
2584	& "MPP MOVE DIM: too much dimension in mpp "//&
2585	& TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")")
2586	ENDIF
2587
2588	END SUBROUTINE mpp_move_dim
2589	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2590	SUBROUTINE mpp_add_att(td_mpp, td_att)
2591	!-------------------------------------------------------------------
2592	!> @brief
2593	!> This subroutine add global attribute to mpp structure.
2594	!>
2595	!> @author J.Paul
2596	!> @date November, 2013 - Initial version
2597	!>
2598	!> @param[inout] td_mpp mpp strcuture
2599	!> @param[in] td_att attribute strcuture
2600	!-------------------------------------------------------------------
2601
2602	IMPLICIT NONE
2603
2604	! Argument
2605	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2606	TYPE(TATT), INTENT(IN) :: td_att
2607
2608	! local variable
2609	INTEGER(i4) :: il_attid
2610
2611	! loop indices
2612	INTEGER(i4) :: ji
2613	!----------------------------------------------------------------
2614
2615	! check if mpp exist
2616	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
2617
2618	CALL logger_error( "MPP ADD ATT: domain decomposition not define "//&
2619	& "for mpp "//TRIM(td_mpp%c_name))
2620
2621	ELSE
2622	! check if variable exist
2623	IF( TRIM(td_att%c_name) == '' )THEN
2624	CALL logger_error("MPP ADD ATT: attribute not define ")
2625	ELSE
2626	! check if attribute already in mpp structure
2627	il_attid=0
2628	IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
2629	il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), &
2630	& td_att%c_name )
2631	ENDIF
2632	IF( il_attid /= 0 )THEN
2633
2634	CALL logger_error( " MPP ADD ATT: attribute "//&
2635	& TRIM(td_att%c_name)//&
2636	& ", already in mpp "//TRIM(td_mpp%c_name) )
2637
2638	DO ji=1,td_mpp%t_proc(1)%i_natt
2639	CALL logger_debug( " MPP ADD ATT: in mpp structure : &
2640	& attribute "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) )
2641	ENDDO
2642
2643	ELSE
2644
2645	CALL logger_info( &
2646	& " MPP ADD ATT: add attribute "//TRIM(td_att%c_name)//&
2647	& ", in mpp "//TRIM(td_mpp%c_name) )
2648
2649	! add attribute in each processor
2650	DO ji=1,td_mpp%i_nproc
2651
2652	CALL file_add_att(td_mpp%t_proc(ji), td_att)
2653
2654	ENDDO
2655
2656	ENDIF
2657	ENDIF
2658	ENDIF
2659
2660	END SUBROUTINE mpp_add_att
2661	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2662	SUBROUTINE mpp__del_att_str(td_mpp, td_att)
2663	!-------------------------------------------------------------------
2664	!> @brief
2665	!> This subroutine delete attribute in mpp structure, given attribute
2666	!> structure.
2667	!>
2668	!> @author J.Paul
2669	!> @date November, 2013 - Initial version
2670	!>
2671	!> @param[inout] td_mpp mpp strcuture
2672	!> @param[in] td_att attribute strcuture
2673	!-------------------------------------------------------------------
2674
2675	IMPLICIT NONE
2676
2677	! Argument
2678	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2679	TYPE(TATT), INTENT(IN) :: td_att
2680
2681	! local variable
2682	INTEGER(i4) :: il_attid
2683	CHARACTER(LEN=lc) :: cl_name
2684
2685	! loop indices
2686	INTEGER(i4) :: ji
2687	!----------------------------------------------------------------
2688
2689	! check if mpp exist
2690	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
2691
2692	CALL logger_warn( "MPP DEL VAR: domain decomposition not define "//&
2693	& " in mpp strcuture "//TRIM(td_mpp%c_name))
2694
2695	ELSE
2696
2697	! check if attribute already in mpp structure
2698	il_attid=0
2699	IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
2700	il_attid=att_get_index( td_mpp%t_proc(1)%t_att(:), &
2701	& td_att%c_name )
2702	ENDIF
2703	IF( il_attid == 0 )THEN
2704	CALL logger_warn( &
2705	& "MPP DEL VAR: no attribute "//TRIM(td_att%c_name)//&
2706	& ", in mpp structure "//TRIM(td_mpp%c_name) )
2707
2708	IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
2709	DO ji=1,td_mpp%t_proc(1)%i_natt
2710	CALL logger_debug( "MPP DEL ATT: in mpp structure : &
2711	& attribute : "//TRIM(td_mpp%t_proc(1)%t_att(ji)%c_name) )
2712	ENDDO
2713	ENDIF
2714
2715	ELSE
2716
2717	cl_name=TRIM(td_att%c_name)
2718	CALL logger_debug( "MPP DEL ATT: delete in mpp structure : &
2719	& attribute : "//TRIM(cl_name) )
2720	DO ji=1,td_mpp%i_nproc
2721	CALL file_del_att(td_mpp%t_proc(ji), TRIM(cl_name))
2722	ENDDO
2723
2724	ENDIF
2725	ENDIF
2726
2727	END SUBROUTINE mpp__del_att_str
2728	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2729	SUBROUTINE mpp__del_att_name(td_mpp, cd_name)
2730	!-------------------------------------------------------------------
2731	!> @brief
2732	!> This subroutine delete attribute in mpp structure, given attribute name.
2733	!>
2734	!> @detail
2735	!>
2736	!> @author J.Paul
2737	!> @date November, 2013 - Initial version
2738	!> @date February, 2015
2739	!> - define local attribute structure to avoid mistake with pointer
2740	!> @date January, 2019
2741	!> - clean attributes structure
2742	!>
2743	!> @param[inout] td_mpp mpp strcuture
2744	!> @param[in] cd_name attribute name
2745	!-------------------------------------------------------------------
2746
2747	IMPLICIT NONE
2748
2749	! Argument
2750	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
2751	CHARACTER(LEN=*) , INTENT(IN ) :: cd_name
2752
2753	! local variable
2754	INTEGER(i4) :: il_attid
2755	TYPE(TATT) :: tl_att
2756	!----------------------------------------------------------------
2757
2758	! check if mpp exist
2759	IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN
2760
2761	CALL logger_warn( "MPP DEL ATT: domain decomposition not define "//&
2762	& " in mpp strcuture "//TRIM(td_mpp%c_name))
2763
2764	ELSE
2765
2766	IF( td_mpp%t_proc(1)%i_natt == 0 )THEN
2767	CALL logger_debug( "MPP DEL ATT NAME: no attribute associated to mpp &
2768	& structure "//TRIM(td_mpp%c_name) )
2769	ELSE
2770
2771	! get the attribute id, in file variable structure
2772	il_attid=0
2773	IF( ASSOCIATED(td_mpp%t_proc(1)%t_att) )THEN
2774	il_attid=att_get_id( td_mpp%t_proc(1)%t_att(:), &
2775	& cd_name )
2776	ENDIF
2777
2778	IF( il_attid == 0 )THEN
2779
2780	CALL logger_debug( &
2781	& "MPP DEL ATT : there is no attribute with "//&
2782	& "name "//TRIM(cd_name)//" in mpp structure "//&
2783	& TRIM(td_mpp%c_name))
2784
2785	ELSE
2786
2787	tl_att=att_copy(td_mpp%t_proc(1)%t_att(il_attid))
2788	CALL mpp_del_att(td_mpp, tl_att)
2789	! clean
2790	CALL att_clean(tl_att)
2791	ENDIF
2792	ENDIF
2793	ENDIF
2794
2795	END SUBROUTINE mpp__del_att_name
2796	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2797	SUBROUTINE mpp_move_att(td_mpp, td_att)
2798	!-------------------------------------------------------------------
2799	!> @brief
2800	!> This subroutine overwrite attribute in mpp structure.
2801	!>
2802	!> @author J.Paul
2803	!> @date November, 2013 - Initial version
2804	!>
2805	!> @param[inout] td_mpp mpp strcuture
2806	!> @param[in] td_att attribute structure
2807	!-------------------------------------------------------------------
2808
2809	IMPLICIT NONE
2810
2811	! Argument
2812	TYPE(TMPP), INTENT(INOUT) :: td_mpp
2813	TYPE(TATT), INTENT(IN) :: td_att
2814
2815	!local variable
2816	TYPE(TATT) :: tl_att
2817	!----------------------------------------------------------------
2818
2819	! copy variable
2820	tl_att=att_copy(td_att)
2821
2822	! remove processor
2823	CALL mpp_del_att(td_mpp, tl_att)
2824
2825	! add processor
2826	CALL mpp_add_att(td_mpp, tl_att)
2827
2828	! clean
2829	CALL att_clean(tl_att)
2830
2831	END SUBROUTINE mpp_move_att
2832	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2833	FUNCTION layout__init(td_mpp, id_mask, id_niproc, id_njproc) &
2834	& RESULT(tf_lay)
2835	!-------------------------------------------------------------------
2836	!> @brief
2837	!> This function initialise domain layout
2838	!>
2839	!> @detail
2840	!> Domain layout is first computed, with domain dimension, overlap between subdomain,
2841	!> and the number of processors following I and J.
2842	!> Then the number of sea/land processors is compute with mask
2843	!>
2844	!> @author J.Paul
2845	!> @date October, 2015 - Initial version
2846	!> @date October, 2016
2847	!> - compare index to tf_lay number of proc instead of td_mpp (bug fix)
2848	!>
2849	!> @param[in] td_mpp mpp strcuture
2850	!> @param[in] id_mask sub domain mask (sea=1, land=0)
2851	!> @pâram[in] id_niproc number of processors following I
2852	!> @pâram[in] id_njproc number of processors following J
2853	!> @return domain layout structure
2854	!-------------------------------------------------------------------
2855
2856	IMPLICIT NONE
2857
2858	! Argument
2859	TYPE(TMPP) , INTENT(IN) :: td_mpp
2860	INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
2861	INTEGER(i4) , INTENT(IN) :: id_niproc
2862	INTEGER(i4) , INTENT(IN) :: id_njproc
2863
2864	! function
2865	TYPE(TLAY) :: tf_lay
2866
2867	! local variable
2868	INTEGER(i4) :: ii1, ii2
2869	INTEGER(i4) :: ij1, ij2
2870
2871	INTEGER(i4) :: il_ldi
2872	INTEGER(i4) :: il_ldj
2873	INTEGER(i4) :: il_lei
2874	INTEGER(i4) :: il_lej
2875
2876	INTEGER(i4) :: il_isize !< i-direction maximum sub domain size
2877	INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size
2878	INTEGER(i4) :: il_resti !<
2879	INTEGER(i4) :: il_restj !<
2880
2881	! loop indices
2882	INTEGER(i4) :: ji
2883	INTEGER(i4) :: jj
2884	!----------------------------------------------------------------
2885
2886	! intialise
2887	tf_lay%i_niproc=id_niproc
2888	tf_lay%i_njproc=id_njproc
2889
2890	CALL logger_info( "MPP COMPUTE LAYOUT: compute domain layout with "//&
2891	& TRIM(fct_str(tf_lay%i_niproc))//" x "//&
2892	& TRIM(fct_str(tf_lay%i_njproc))//" processors")
2893
2894	! maximum size of sub domain
2895	il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (tf_lay%i_niproc-1))/ &
2896	& tf_lay%i_niproc) + 2*td_mpp%i_preci
2897	il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (tf_lay%i_njproc-1))/ &
2898	& tf_lay%i_njproc) + 2*td_mpp%i_precj
2899
2900	il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, tf_lay%i_niproc)
2901	il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, tf_lay%i_njproc)
2902	IF( il_resti == 0 ) il_resti = tf_lay%i_niproc
2903	IF( il_restj == 0 ) il_restj = tf_lay%i_njproc
2904
2905	! compute dimension of each sub domain
2906	ALLOCATE( tf_lay%i_lci(tf_lay%i_niproc,tf_lay%i_njproc) )
2907	ALLOCATE( tf_lay%i_lcj(tf_lay%i_niproc,tf_lay%i_njproc) )
2908
2909	tf_lay%i_lci( 1 : il_resti , : ) = il_isize
2910	tf_lay%i_lci( il_resti+1 : tf_lay%i_niproc, : ) = il_isize-1
2911
2912	tf_lay%i_lcj( : , 1 : il_restj ) = il_jsize
2913	tf_lay%i_lcj( : , il_restj+1 : tf_lay%i_njproc) = il_jsize-1
2914
2915	! compute first index of each sub domain
2916	ALLOCATE( tf_lay%i_impp(tf_lay%i_niproc,tf_lay%i_njproc) )
2917	ALLOCATE( tf_lay%i_jmpp(tf_lay%i_niproc,tf_lay%i_njproc) )
2918
2919	tf_lay%i_impp(:,:)=1
2920	tf_lay%i_jmpp(:,:)=1
2921
2922	IF( tf_lay%i_niproc > 1 )THEN
2923	DO jj=1,tf_lay%i_njproc
2924	DO ji=2,tf_lay%i_niproc
2925	tf_lay%i_impp(ji,jj) = tf_lay%i_impp(ji-1,jj) + &
2926	& tf_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci
2927	ENDDO
2928	ENDDO
2929	ENDIF
2930
2931	IF( tf_lay%i_njproc > 1 )THEN
2932	DO jj=2,tf_lay%i_njproc
2933	DO ji=1,tf_lay%i_niproc
2934	tf_lay%i_jmpp(ji,jj) = tf_lay%i_jmpp(ji,jj-1) + &
2935	& tf_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj
2936	ENDDO
2937	ENDDO
2938	ENDIF
2939
2940	ALLOCATE( tf_lay%i_msk(tf_lay%i_niproc,tf_lay%i_njproc) )
2941	tf_lay%i_msk(:,:)=0
2942	! init number of sea/land proc
2943	tf_lay%i_nsea=0
2944	tf_lay%i_nland=tf_lay%i_njproc*tf_lay%i_niproc
2945
2946	! check if processor is land or sea
2947	DO jj = 1,tf_lay%i_njproc
2948	DO ji = 1,tf_lay%i_niproc
2949
2950	! compute first and last indoor indices
2951	! west boundary
2952	IF( ji == 1 )THEN
2953	il_ldi = 1
2954	ELSE
2955	il_ldi = 1 + td_mpp%i_preci
2956	ENDIF
2957
2958	! south boundary
2959	IF( jj == 1 )THEN
2960	il_ldj = 1
2961	ELSE
2962	il_ldj = 1 + td_mpp%i_precj
2963	ENDIF
2964
2965	! east boundary
2966	IF( ji == tf_lay%i_niproc )THEN
2967	il_lei = tf_lay%i_lci(ji,jj)
2968	ELSE
2969	il_lei = tf_lay%i_lci(ji,jj) - td_mpp%i_preci
2970	ENDIF
2971
2972	! north boundary
2973	IF( jj == tf_lay%i_njproc )THEN
2974	il_lej = tf_lay%i_lcj(ji,jj)
2975	ELSE
2976	il_lej = tf_lay%i_lcj(ji,jj) - td_mpp%i_precj
2977	ENDIF
2978
2979	ii1=tf_lay%i_impp(ji,jj) + il_ldi - 1
2980	ii2=tf_lay%i_impp(ji,jj) + il_lei - 1
2981
2982	ij1=tf_lay%i_jmpp(ji,jj) + il_ldj - 1
2983	ij2=tf_lay%i_jmpp(ji,jj) + il_lej - 1
2984
2985	tf_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) )
2986	IF( tf_lay%i_msk(ji,jj) > 0 )THEN ! sea
2987	tf_lay%i_nsea =tf_lay%i_nsea +1
2988	tf_lay%i_nland=tf_lay%i_nland-1
2989	ENDIF
2990
2991	ENDDO
2992	ENDDO
2993
2994	CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(tf_lay%i_nsea)))
2995	CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(tf_lay%i_nland)))
2996	CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(tf_lay%i_msk(:,:)))))
2997
2998	tf_lay%i_mean= SUM(tf_lay%i_msk(:,:)) / tf_lay%i_nsea
2999	tf_lay%i_min = MINVAL(tf_lay%i_msk(:,:),tf_lay%i_msk(:,:)/=0)
3000	tf_lay%i_max = MAXVAL(tf_lay%i_msk(:,:))
3001
3002	IF( lm_layout )THEN
3003	! print info
3004	WRITE(im_iumout,*) ' '
3005	WRITE(im_iumout,*) " jpni=",tf_lay%i_niproc ," jpnj=",tf_lay%i_njproc
3006	WRITE(im_iumout,*) " jpi= ",il_isize," jpj= ",il_jsize
3007	WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj
3008
3009
3010	WRITE(im_iumout,) ' nombre de processeurs ',tf_lay%i_niproctf_lay%i_njproc
3011	WRITE(im_iumout,*) ' nombre de processeurs mer ',tf_lay%i_nsea
3012	WRITE(im_iumout,*) ' nombre de processeurs terre ',tf_lay%i_nland
3013	WRITE(im_iumout,*) ' moyenne de recouvrement ',tf_lay%i_mean
3014	WRITE(im_iumout,*) ' minimum de recouvrement ',tf_lay%i_min
3015	WRITE(im_iumout,*) ' maximum de recouvrement ',tf_lay%i_max
3016	ENDIF
3017
3018	END FUNCTION layout__init
3019	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3020	SUBROUTINE layout__clean(td_lay)
3021	!-------------------------------------------------------------------
3022	!> @brief
3023	!> This subroutine clean domain layout strcuture.
3024	!>
3025	!> @author J.Paul
3026	!> @date October, 2015 - Initial version
3027	!> @date January, 2019
3028	!> - nullify array in layout structure
3029	!>
3030	!> @param[inout] td_lay domain layout strcuture
3031	!-------------------------------------------------------------------
3032
3033	IMPLICIT NONE
3034
3035	! Argument
3036	TYPE(TLAY), INTENT(INOUT) :: td_lay
3037	!----------------------------------------------------------------
3038
3039	IF( ASSOCIATED(td_lay%i_msk) )THEN
3040	DEALLOCATE(td_lay%i_msk)
3041	NULLIFY(td_lay%i_msk)
3042	ENDIF
3043	IF( ASSOCIATED(td_lay%i_impp) )THEN
3044	DEALLOCATE(td_lay%i_impp)
3045	NULLIFY(td_lay%i_impp)
3046	ENDIF
3047	IF( ASSOCIATED(td_lay%i_jmpp) )THEN
3048	DEALLOCATE(td_lay%i_jmpp)
3049	NULLIFY(td_lay%i_jmpp)
3050	ENDIF
3051	IF( ASSOCIATED(td_lay%i_lci) )THEN
3052	DEALLOCATE(td_lay%i_lci)
3053	NULLIFY(td_lay%i_lci)
3054	ENDIF
3055	IF( ASSOCIATED(td_lay%i_lcj) )THEN
3056	DEALLOCATE(td_lay%i_lcj)
3057	NULLIFY(td_lay%i_lcj)
3058	ENDIF
3059
3060	td_lay%i_niproc=0
3061	td_lay%i_njproc=0
3062	td_lay%i_nland =0
3063	td_lay%i_nsea =0
3064
3065	td_lay%i_mean =0
3066	td_lay%i_min =0
3067	td_lay%i_max =0
3068
3069	END SUBROUTINE layout__clean
3070	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3071	FUNCTION layout__copy(td_lay) &
3072	& RESULT(tf_lay)
3073	!-------------------------------------------------------------------
3074	!> @brief
3075	!> This subroutine copy domain layout structure in another one.
3076	!>
3077	!> @warning do not use on the output of a function who create or read a
3078	!> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden).
3079	!> This will create memory leaks.
3080	!> @warning to avoid infinite loop, do not use any function inside
3081	!> this subroutine
3082	!>
3083	!> @author J.Paul
3084	!> @date October, 2015 - Initial Version
3085	!>
3086	!> @param[in] td_lay domain layout structure
3087	!> @return copy of input domain layout structure
3088	!-------------------------------------------------------------------
3089
3090	IMPLICIT NONE
3091
3092	! Argument
3093	TYPE(TLAY), INTENT(IN) :: td_lay
3094	! function
3095	TYPE(TLAY) :: tf_lay
3096
3097	! local variable
3098	INTEGER(i4), DIMENSION(2) :: il_shape
3099	INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp
3100	! loop indices
3101	!----------------------------------------------------------------
3102
3103	! copy scalar
3104	tf_lay%i_niproc = td_lay%i_niproc
3105	tf_lay%i_njproc = td_lay%i_njproc
3106	tf_lay%i_nland = td_lay%i_nland
3107	tf_lay%i_nsea = td_lay%i_nsea
3108	tf_lay%i_mean = td_lay%i_mean
3109	tf_lay%i_min = td_lay%i_min
3110	tf_lay%i_max = td_lay%i_max
3111
3112	! copy pointers
3113	IF( ASSOCIATED(tf_lay%i_msk) )THEN
3114	DEALLOCATE(tf_lay%i_msk)
3115	ENDIF
3116	IF( ASSOCIATED(td_lay%i_msk) )THEN
3117	il_shape(:)=SHAPE(td_lay%i_msk(:,:))
3118	ALLOCATE( tf_lay%i_msk(il_shape(jp_I),il_shape(jp_J)) )
3119	tf_lay%i_msk(:,:)=td_lay%i_msk(:,:)
3120	ENDIF
3121
3122	IF( ASSOCIATED(tf_lay%i_msk) ) DEALLOCATE(tf_lay%i_msk)
3123	IF( ASSOCIATED(td_lay%i_msk) )THEN
3124	il_shape(:)=SHAPE(td_lay%i_msk(:,:))
3125	ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
3126	il_tmp(:,:)=td_lay%i_msk(:,:)
3127
3128	ALLOCATE( tf_lay%i_msk(il_shape(jp_I),il_shape(jp_J)) )
3129	tf_lay%i_msk(:,:)=il_tmp(:,:)
3130
3131	DEALLOCATE(il_tmp)
3132	ENDIF
3133
3134	IF( ASSOCIATED(tf_lay%i_impp) ) DEALLOCATE(tf_lay%i_impp)
3135	IF( ASSOCIATED(td_lay%i_impp) )THEN
3136	il_shape(:)=SHAPE(td_lay%i_impp(:,:))
3137	ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
3138	il_tmp(:,:)=td_lay%i_impp(:,:)
3139
3140	ALLOCATE( tf_lay%i_impp(il_shape(jp_I),il_shape(jp_J)) )
3141	tf_lay%i_impp(:,:)=il_tmp(:,:)
3142
3143	DEALLOCATE(il_tmp)
3144	ENDIF
3145
3146	IF( ASSOCIATED(tf_lay%i_jmpp) ) DEALLOCATE(tf_lay%i_jmpp)
3147	IF( ASSOCIATED(td_lay%i_jmpp) )THEN
3148	il_shape(:)=SHAPE(td_lay%i_jmpp(:,:))
3149	ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
3150	il_tmp(:,:)=td_lay%i_jmpp(:,:)
3151
3152	ALLOCATE( tf_lay%i_jmpp(il_shape(jp_I),il_shape(jp_J)) )
3153	tf_lay%i_jmpp(:,:)=il_tmp(:,:)
3154
3155	DEALLOCATE(il_tmp)
3156	ENDIF
3157
3158	IF( ASSOCIATED(tf_lay%i_lci) ) DEALLOCATE(tf_lay%i_lci)
3159	IF( ASSOCIATED(td_lay%i_lci) )THEN
3160	il_shape(:)=SHAPE(td_lay%i_lci(:,:))
3161	ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
3162	il_tmp(:,:)=td_lay%i_lci(:,:)
3163
3164	ALLOCATE( tf_lay%i_lci(il_shape(jp_I),il_shape(jp_J)) )
3165	tf_lay%i_lci(:,:)=il_tmp(:,:)
3166
3167	DEALLOCATE(il_tmp)
3168	ENDIF
3169
3170	IF( ASSOCIATED(tf_lay%i_lcj) ) DEALLOCATE(tf_lay%i_lcj)
3171	IF( ASSOCIATED(td_lay%i_lcj) )THEN
3172	il_shape(:)=SHAPE(td_lay%i_lcj(:,:))
3173	ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J)))
3174	il_tmp(:,:)=td_lay%i_lcj(:,:)
3175
3176	ALLOCATE( tf_lay%i_lcj(il_shape(jp_I),il_shape(jp_J)) )
3177	tf_lay%i_lcj(:,:)=il_tmp(:,:)
3178
3179	DEALLOCATE(il_tmp)
3180	ENDIF
3181
3182	END FUNCTION layout__copy
3183	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3184	SUBROUTINE mpp__create_layout(td_mpp, td_lay)
3185	!-------------------------------------------------------------------
3186	!> @brief
3187	!> This subroutine create mpp structure using domain layout
3188	!>
3189	!> @detail
3190	!>
3191	!> @author J.Paul
3192	!> @date October, 2015 - Initial version
3193	!> @date August, 2017
3194	!> - handle use of domain decomposition for monoproc file
3195	!>
3196	!> @param[inout] td_mpp mpp strcuture
3197	!> @param[in] td_lay domain layout structure
3198	!-------------------------------------------------------------------
3199
3200	IMPLICIT NONE
3201
3202	! Argument
3203	TYPE(TMPP), INTENT(INOUT) :: td_mpp
3204	TYPE(TLAY), INTENT(IN ) :: td_lay
3205
3206	! local variable
3207	CHARACTER(LEN=lc) :: cl_file
3208	TYPE(TATT) :: tl_att
3209
3210	TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc
3211
3212	! loop indices
3213	INTEGER(i4) :: ji
3214	INTEGER(i4) :: jj
3215	INTEGER(i4) :: jk
3216	!----------------------------------------------------------------
3217
3218	! intialise
3219	td_mpp%i_nproc=0
3220
3221	CALL logger_debug( "MPP CREATE LAYOUT: create domain decomposition with "//&
3222	& TRIM(fct_str(td_lay%i_niproc))//" x "//&
3223	& TRIM(fct_str(td_lay%i_njproc))//" = "//&
3224	& TRIM(fct_str(td_lay%i_nsea))//" processors")
3225
3226	IF( lm_layout )THEN
3227	WRITE(im_iumout,*) ' choix optimum'
3228	WRITE(im_iumout,*) ' ============='
3229	WRITE(im_iumout,*)
3230	! print info
3231	WRITE(im_iumout,*) ' '
3232	WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc
3233	WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj
3234
3235
3236	WRITE(im_iumout,) ' nombre de processeurs ',td_lay%i_niproctd_lay%i_njproc
3237	WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea
3238	WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland
3239	WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean
3240	WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min
3241	WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max
3242	ENDIF
3243
3244	td_mpp%i_niproc=td_lay%i_niproc
3245	td_mpp%i_njproc=td_lay%i_njproc
3246	!td_mpp%i_nproc =td_lay%i_nsea
3247
3248	IF( td_mpp%i_niproc*td_mpp%i_njproc == td_lay%i_nsea )THEN
3249	IF( td_lay%i_nsea == 1 )THEN
3250	td_mpp%c_dom='full'
3251	ELSE
3252	td_mpp%c_dom='nooverlap'
3253	ENDIF
3254	ELSE
3255	td_mpp%c_dom='noextra'
3256	ENDIF
3257
3258	ALLOCATE(tl_proc(td_lay%i_nsea))
3259	jk=1
3260	DO jj=1,td_lay%i_njproc
3261	DO ji=1,td_lay%i_niproc
3262
3263	IF( td_lay%i_msk(ji,jj) >= 1 )THEN
3264
3265	! get processor file name
3266	IF( td_mpp%l_usempp )THEN
3267	cl_file=file_rename(td_mpp%c_name,jk)
3268	ELSE
3269	cl_file=TRIM(td_mpp%c_name)
3270	ENDIF
3271	! initialise file structure
3272	tl_proc(jk)=file_init(cl_file,td_mpp%c_type)
3273
3274	! procesor id
3275	tl_proc(jk)%i_pid=jk-1
3276
3277	tl_att=att_init("DOMAIN_number",tl_proc(jk)%i_pid)
3278	CALL file_add_att(tl_proc(jk), tl_att)
3279
3280	! processor indices
3281	tl_proc(jk)%i_iind=ji
3282	tl_proc(jk)%i_jind=jj
3283
3284	! fill processor dimension and first indices
3285	tl_proc(jk)%i_impp = td_lay%i_impp(ji,jj)
3286	tl_proc(jk)%i_jmpp = td_lay%i_jmpp(ji,jj)
3287
3288	tl_proc(jk)%i_lci = td_lay%i_lci(ji,jj)
3289	tl_proc(jk)%i_lcj = td_lay%i_lcj(ji,jj)
3290
3291	! compute first and last indoor indices
3292
3293	! west boundary
3294	IF( ji == 1 )THEN
3295	tl_proc(jk)%i_ldi = 1
3296	tl_proc(jk)%l_ctr = .TRUE.
3297	ELSE
3298	tl_proc(jk)%i_ldi = 1 + td_mpp%i_preci
3299	ENDIF
3300
3301	! south boundary
3302	IF( jj == 1 )THEN
3303	tl_proc(jk)%i_ldj = 1
3304	tl_proc(jk)%l_ctr = .TRUE.
3305	ELSE
3306	tl_proc(jk)%i_ldj = 1 + td_mpp%i_precj
3307	ENDIF
3308
3309	! east boundary
3310	IF( ji == td_mpp%i_niproc )THEN
3311	tl_proc(jk)%i_lei = td_lay%i_lci(ji,jj)
3312	tl_proc(jk)%l_ctr = .TRUE.
3313	ELSE
3314	tl_proc(jk)%i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci
3315	ENDIF
3316
3317	! north boundary
3318	IF( jj == td_mpp%i_njproc )THEN
3319	tl_proc(jk)%i_lej = td_lay%i_lcj(ji,jj)
3320	tl_proc(jk)%l_ctr = .TRUE.
3321	ELSE
3322	tl_proc(jk)%i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj
3323	ENDIF
3324
3325	! clean
3326	CALL att_clean(tl_att)
3327
3328	! update proc number
3329	jk=jk+1
3330
3331	ENDIF
3332	ENDDO
3333	ENDDO
3334	!
3335	CALL mpp__add_proc(td_mpp, tl_proc(:))
3336	DEALLOCATE(tl_proc)
3337
3338	END SUBROUTINE mpp__create_layout
3339	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3340	SUBROUTINE mpp__optimiz(td_mpp, id_mask, id_nproc)
3341	!-------------------------------------------------------------------
3342	!> @brief
3343	!> This subroutine optimize the number of sub domain to be used, given mask.
3344	!> @details
3345	!> Actually it get the domain decomposition with the most land
3346	!> processors removed.
3347	!> If no land processor could be removed, it get the decomposition with the
3348	!> most sea processors.
3349	!>
3350	!> @author J.Paul
3351	!> @date November, 2013 - Initial version
3352	!> @date October, 2015
3353	!> - improve way to compute domain layout
3354	!> @date February, 2016
3355	!> - new criteria for domain layout in case no land proc
3356	!>
3357	!> @param[inout] td_mpp mpp strcuture
3358	!> @param[in] id_mask sub domain mask (sea=1, land=0)
3359	!> @pram[in] id_nproc maximum number of processor to be used
3360	!-------------------------------------------------------------------
3361
3362	IMPLICIT NONE
3363
3364	! Argument
3365	TYPE(TMPP), INTENT(INOUT) :: td_mpp
3366	INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask
3367	INTEGER(i4) , INTENT(IN) :: id_nproc
3368
3369	! local variable
3370	TYPE(TLAY) :: tl_lay
3371	TYPE(TLAY) :: tl_sav
3372
3373	REAL(dp) :: dl_min
3374	REAL(dp) :: dl_max
3375	REAL(dp) :: dl_ratio
3376	REAL(dp) :: dl_sav
3377
3378	! loop indices
3379	INTEGER(i4) :: ji
3380	INTEGER(i4) :: jj
3381	!----------------------------------------------------------------
3382
3383	CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition")
3384	dl_sav=0
3385	!
3386	DO ji=1,id_nproc
3387	DO jj=1,id_nproc
3388
3389	! compute domain layout
3390	tl_lay=layout__init( td_mpp, id_mask, ji,jj )
3391	IF( tl_lay%i_nsea <= id_nproc )THEN
3392
3393	IF( ASSOCIATED(tl_sav%i_lci) )THEN
3394	IF( tl_sav%i_nland /= 0 )THEN
3395	! look for layout with most land proc
3396	IF( tl_lay%i_nland > tl_sav%i_nland .OR. &
3397	& ( tl_lay%i_nland == tl_sav%i_nland .AND. &
3398	& tl_lay%i_min > tl_sav%i_min ) )THEN
3399	! save optimiz layout
3400	CALL logger_info("MPP OPTIMIZ:save this decomposition "//&
3401	& TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//&
3402	& TRIM(fct_str(tl_lay%i_nsea)) )
3403
3404	tl_sav=layout__copy(tl_lay)
3405	ENDIF
3406	ELSE ! tl_sav%i_nland == 0
3407	! look for layout with most sea proc
3408	! and "square" cell
3409	dl_min=MIN(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1))
3410	dl_max=MAX(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1))
3411	dl_ratio=dl_min/dl_max
3412	IF( tl_lay%i_nsea > tl_sav%i_nsea .OR. &
3413	& ( tl_lay%i_nsea == tl_sav%i_nsea .AND. &
3414	& dl_ratio > dl_sav ) )THEN
3415	! save optimiz layout
3416	CALL logger_info("MPP OPTIMIZ:save this decomposition "//&
3417	& TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//&
3418	& TRIM(fct_str(tl_lay%i_nsea)) )
3419
3420	tl_sav=layout__copy(tl_lay)
3421	dl_sav=dl_ratio
3422	ENDIF
3423	ENDIF
3424	ELSE
3425	! init tl_sav
3426	tl_sav=layout__copy(tl_lay)
3427
3428	dl_min=MIN(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1))
3429	dl_max=MAX(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1))
3430	dl_sav=dl_min/dl_max
3431	ENDIF
3432
3433	ENDIF
3434
3435	! clean
3436	CALL layout__clean( tl_lay )
3437
3438	ENDDO
3439	ENDDO
3440
3441	! create mpp domain layout
3442	CALL mpp__create_layout(td_mpp, tl_sav)
3443
3444	! clean
3445	CALL layout__clean( tl_sav )
3446
3447	END SUBROUTINE mpp__optimiz
3448	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3449	SUBROUTINE mpp__clean_unit(td_mpp)
3450	!-------------------------------------------------------------------
3451	!> @brief
3452	!> This subroutine clean mpp strcuture.
3453	!>
3454	!> @author J.Paul
3455	!> @date November, 2013 - Initial version
3456	!> @date January, 2019
3457	!> - nullify file structure inside mpp structure
3458	!>
3459	!> @param[inout] td_mpp mpp strcuture
3460	!-------------------------------------------------------------------
3461
3462	IMPLICIT NONE
3463
3464	! Argument
3465	TYPE(TMPP), INTENT(INOUT) :: td_mpp
3466
3467	! local variable
3468	TYPE(TMPP) :: tl_mpp ! empty mpp structure
3469
3470	! loop indices
3471	!----------------------------------------------------------------
3472
3473	CALL logger_info( &
3474	& "MPP CLEAN: reset mpp "//TRIM(td_mpp%c_name) )
3475
3476	! del dimension
3477	IF( td_mpp%i_ndim /= 0 )THEN
3478	CALL dim_clean( td_mpp%t_dim(:) )
3479	ENDIF
3480
3481	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3482	! clean array of file processor
3483	CALL file_clean( td_mpp%t_proc(:) )
3484	DEALLOCATE(td_mpp%t_proc)
3485	NULLIFY(td_mpp%t_proc)
3486	ENDIF
3487
3488	! replace by empty structure
3489	td_mpp=mpp_copy(tl_mpp)
3490
3491	END SUBROUTINE mpp__clean_unit
3492	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3493	!-------------------------------------------------------------------
3494	!> @brief
3495	!> This subroutine clean mpp strcuture.
3496	!>
3497	!> @author J.Paul
3498	!> @date November, 2013 - Initial version
3499	!>
3500	!> @param[inout] td_mpp mpp strcuture
3501	!-------------------------------------------------------------------
3502	SUBROUTINE mpp__clean_arr(td_mpp)
3503
3504	IMPLICIT NONE
3505	! Argument
3506	TYPE(TMPP), DIMENSION(:), INTENT(INOUT) :: td_mpp
3507
3508	! local variable
3509	! loop indices
3510	INTEGER(i4) :: ji
3511	!----------------------------------------------------------------
3512
3513	DO ji=SIZE(td_mpp(:)),1,-1
3514	CALL mpp_clean(td_mpp(ji))
3515	ENDDO
3516
3517	END SUBROUTINE mpp__clean_arr
3518	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3519	SUBROUTINE mpp__get_use_unit(td_mpp, id_imin, id_imax, id_jmin, id_jmax)
3520	!-------------------------------------------------------------------
3521	!> @brief
3522	!> This subroutine get sub domains which cover "zoom domain".
3523	!> proc use in "zoom domain"
3524	!>
3525	!> @author J.Paul
3526	!> @date November, 2013 - Initial version
3527	!>
3528	!> @param[inout] td_mpp mpp strcuture
3529	!> @param[in] id_imin i-direction lower indice
3530	!> @param[in] id_imax i-direction upper indice
3531	!> @param[in] id_jmin j-direction lower indice
3532	!> @param[in] id_jmax j-direction upper indice
3533	!-------------------------------------------------------------------
3534
3535	IMPLICIT NONE
3536
3537	! Argument
3538	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
3539	INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin
3540	INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax
3541	INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin
3542	INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax
3543
3544	! local variable
3545	LOGICAL :: ll_iuse
3546	LOGICAL :: ll_juse
3547
3548	INTEGER(i4) :: il_imin
3549	INTEGER(i4) :: il_imax
3550	INTEGER(i4) :: il_jmin
3551	INTEGER(i4) :: il_jmax
3552
3553	! loop indices
3554	INTEGER(i4) :: jk
3555	!----------------------------------------------------------------
3556
3557	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3558
3559	il_imin=1
3560	il_imax=td_mpp%t_dim(1)%i_len
3561	IF( PRESENT(id_imin) ) il_imin=id_imin
3562	IF( PRESENT(id_imax) ) il_imax=id_imax
3563	il_jmin=1
3564	il_jmax=td_mpp%t_dim(2)%i_len
3565	IF( PRESENT(id_jmin) ) il_jmin=id_jmin
3566	IF( PRESENT(id_jmax) ) il_jmax=id_jmax
3567
3568	! check domain
3569	IF( il_imin < 1 .OR. il_imin > td_mpp%t_dim(1)%i_len .OR. &
3570	& il_imax < 1 .OR. il_imax > td_mpp%t_dim(1)%i_len .OR. &
3571	& il_jmin < 1 .OR. il_jmin > td_mpp%t_dim(2)%i_len .OR. &
3572	& il_jmax < 1 .OR. il_jmax > td_mpp%t_dim(2)%i_len )THEN
3573	CALL logger_debug("MPP GET USE: mpp gloabl size "//&
3574	& TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&
3575	& TRIM(fct_str(td_mpp%t_dim(2)%i_len)))
3576	CALL logger_debug("MPP GET USE: i-indices "//&
3577	& TRIM(fct_str(il_imin))//","//TRIM(fct_str(il_imax)))
3578	CALL logger_debug("MPP GET USE: j-indices "//&
3579	& TRIM(fct_str(il_jmin))//","//TRIM(fct_str(il_jmax)))
3580	CALL logger_error("MPP GET USE: invalid indices ")
3581	ELSE
3582	td_mpp%t_proc(:)%l_use=.FALSE.
3583	DO jk=1,td_mpp%i_nproc
3584
3585	! check i-direction
3586	ll_iuse=.FALSE.
3587	IF( il_imin < il_imax )THEN
3588
3589	! not overlap east west boundary
3590	IF( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
3591	& il_imin .AND. &
3592	& td_mpp%t_proc(jk)%i_impp < il_imax )THEN
3593	ll_iuse=.TRUE.
3594	ENDIF
3595
3596	ELSEIF( il_imin == il_imax )THEN
3597
3598	! east west cyclic
3599	ll_iuse=.TRUE.
3600
3601	ELSE ! il_imin > id_imax
3602
3603	! overlap east west boundary
3604	IF( ( td_mpp%t_proc(jk)%i_impp + td_mpp%t_proc(jk)%i_lci > &
3605	& il_imin ) &
3606	& .OR. &
3607	& ( td_mpp%t_proc(jk)%i_impp < il_imax) )THEN
3608	ll_iuse=.TRUE.
3609	ENDIF
3610
3611	ENDIF
3612
3613	! check j-direction
3614	ll_juse=.FALSE.
3615	IF( il_jmin < il_jmax )THEN
3616
3617	! not overlap north fold
3618	IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
3619	& il_jmin .AND. &
3620	& td_mpp%t_proc(jk)%i_jmpp < il_jmax )THEN
3621	ll_juse=.TRUE.
3622	ENDIF
3623
3624	ELSE ! id_jmin >= id_jmax
3625
3626	IF( td_mpp%t_proc(jk)%i_jmpp + td_mpp%t_proc(jk)%i_lcj > &
3627	& il_jmin )THEN
3628	ll_juse=.TRUE.
3629	ENDIF
3630
3631	ENDIF
3632
3633	IF( ll_iuse .AND. ll_juse ) td_mpp%t_proc(jk)%l_use=.TRUE.
3634
3635	ENDDO
3636	ENDIF
3637
3638	ELSE
3639	CALL logger_error("MPP GET USE: mpp decomposition not define.")
3640	ENDIF
3641
3642	END SUBROUTINE mpp__get_use_unit
3643	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3644	SUBROUTINE mpp_get_contour(td_mpp)
3645	!-------------------------------------------------------------------
3646	!> @brief
3647	!> This subroutine get sub domains which form global domain border.
3648	!>
3649	!> @author J.Paul
3650	!> @date November, 2013 - Initial version
3651	!>
3652	!> @param[inout] td_mpp mpp strcuture
3653	!-------------------------------------------------------------------
3654
3655	IMPLICIT NONE
3656
3657	! Argument
3658	TYPE(TMPP), INTENT(INOUT) :: td_mpp
3659
3660	! loop indices
3661	INTEGER(i4) :: jk
3662	!----------------------------------------------------------------
3663
3664	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3665
3666	td_mpp%t_proc(:)%l_use = .FALSE.
3667	DO jk=1,td_mpp%i_nproc
3668	IF( td_mpp%t_proc(jk)%i_ldi == 1 .OR. &
3669	& td_mpp%t_proc(jk)%i_ldj == 1 .OR. &
3670	& td_mpp%t_proc(jk)%i_lei == td_mpp%t_proc(jk)%i_lci .OR. &
3671	& td_mpp%t_proc(jk)%i_lej == td_mpp%t_proc(jk)%i_lcj )THEN
3672
3673	td_mpp%t_proc(jk)%l_use = .TRUE.
3674
3675	ENDIF
3676	ENDDO
3677
3678	ELSE
3679	CALL logger_error("MPP GET CONTOUR: domain decomposition not define.")
3680	ENDIF
3681
3682	END SUBROUTINE mpp_get_contour
3683	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3684	FUNCTION mpp_get_proc_index(td_mpp, id_procid) &
3685	& RESULT(if_idx)
3686	!-------------------------------------------------------------------
3687	!> @brief
3688	!> This function return processor indices, without overlap boundary,
3689	!> given processor id.
3690	!>
3691	!> @author J.Paul
3692	!> @date November, 2013 - Initial version
3693	!>
3694	!> @param[in] td_mpp mpp strcuture
3695	!> @param[in] id_procid processor id
3696	!> @return array of index (/ i1, i2, j1, j2 /)
3697	!-------------------------------------------------------------------
3698
3699	IMPLICIT NONE
3700
3701	! Argument
3702	TYPE(TMPP) , INTENT(IN) :: td_mpp
3703	INTEGER(i4), INTENT(IN) :: id_procid
3704
3705	! function
3706	INTEGER(i4), DIMENSION(4) :: if_idx
3707
3708	! local variable
3709	INTEGER(i4) :: il_i1, il_i2
3710	INTEGER(i4) :: il_j1, il_j2
3711	!----------------------------------------------------------------
3712
3713	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3714
3715	IF( TRIM(td_mpp%c_dom) == '' )THEN
3716	CALL logger_fatal("MPP GET PROC INDEX: decomposition type unknown. "//&
3717	& "you should ahve run mpp_get_dom before.")
3718	ENDIF
3719
3720	SELECT CASE(TRIM(td_mpp%c_dom))
3721	CASE('full')
3722	il_i1 = 1
3723	il_j1 = 1
3724
3725	il_i2 = td_mpp%t_dim(1)%i_len
3726	il_j2 = td_mpp%t_dim(2)%i_len
3727	CASE('noextra')
3728	il_i1 = td_mpp%t_proc(id_procid)%i_impp
3729	il_j1 = td_mpp%t_proc(id_procid)%i_jmpp
3730
3731	il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1
3732	il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1
3733	CASE('nooverlap')
3734	il_i1 = td_mpp%t_proc(id_procid)%i_impp + &
3735	& td_mpp%t_proc(id_procid)%i_ldi - 1
3736	il_j1 = td_mpp%t_proc(id_procid)%i_jmpp + &
3737	& td_mpp%t_proc(id_procid)%i_ldj - 1
3738
3739	il_i2 = td_mpp%t_proc(id_procid)%i_impp + &
3740	& td_mpp%t_proc(id_procid)%i_lei - 1
3741	il_j2 = td_mpp%t_proc(id_procid)%i_jmpp + &
3742	& td_mpp%t_proc(id_procid)%i_lej - 1
3743	CASE DEFAULT
3744	CALL logger_error("MPP GET PROC INDEX: invalid "//&
3745	& "decomposition type.")
3746	END SELECT
3747
3748	if_idx(:)=(/il_i1, il_i2, il_j1, il_j2/)
3749
3750	ELSE
3751	CALL logger_error("MPP GET PROC INDEX: domain decomposition not define.")
3752	ENDIF
3753
3754	END FUNCTION mpp_get_proc_index
3755	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3756	FUNCTION mpp_get_proc_size(td_mpp, id_procid) &
3757	& RESULT(if_size)
3758	!-------------------------------------------------------------------
3759	!> @brief
3760	!> This function return processor domain size, depending of domain
3761	!> decompisition type, given sub domain id.
3762	!>
3763	!> @author J.Paul
3764	!> @date November, 2013 - Initial version
3765	!>
3766	!> @param[in] td_mpp mpp strcuture
3767	!> @param[in] id_procid sub domain id
3768	!> @return array of index (/ isize, jsize /)
3769	!-------------------------------------------------------------------
3770
3771	IMPLICIT NONE
3772
3773	! Argument
3774	TYPE(TMPP), INTENT(IN) :: td_mpp
3775	INTEGER(i4), INTENT(IN) :: id_procid
3776
3777	! function
3778	INTEGER(i4), DIMENSION(2) :: if_size
3779
3780	! local variable
3781	INTEGER(i4) :: il_isize
3782	INTEGER(i4) :: il_jsize
3783	!----------------------------------------------------------------
3784
3785	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3786
3787	IF( TRIM(td_mpp%c_dom) == '' )THEN
3788	CALL logger_fatal("MPP GET PROC SIZE: decomposition type unknown. "//&
3789	& "you should ahve run mpp_get_dom before.")
3790	ENDIF
3791
3792	SELECT CASE(TRIM(td_mpp%c_dom))
3793	CASE('full')
3794
3795	il_isize = td_mpp%t_dim(1)%i_len
3796	il_jsize = td_mpp%t_dim(2)%i_len
3797
3798	CASE('noextra')
3799
3800	il_isize = td_mpp%t_proc(id_procid)%i_lci
3801	il_jsize = td_mpp%t_proc(id_procid)%i_lcj
3802
3803	CASE('nooverlap')
3804	il_isize = td_mpp%t_proc(id_procid)%i_lei - &
3805	& td_mpp%t_proc(id_procid)%i_ldi + 1
3806	il_jsize = td_mpp%t_proc(id_procid)%i_lej - &
3807	& td_mpp%t_proc(id_procid)%i_ldj + 1
3808	CASE DEFAULT
3809	CALL logger_error("MPP GET PROC SIZE: invalid decomposition type : "//&
3810	& TRIM(td_mpp%c_dom) )
3811	END SELECT
3812
3813	if_size(:)=(/il_isize, il_jsize/)
3814
3815	ELSE
3816	CALL logger_error("MPP GET PROC SIZE: domain decomposition not define.")
3817	ENDIF
3818
3819	END FUNCTION mpp_get_proc_size
3820	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3821	SUBROUTINE mpp_get_dom(td_mpp)
3822	!-------------------------------------------------------------------
3823	!> @brief
3824	!> This subroutine determine domain decomposition type.
3825	!> (full, overlap, noverlap)
3826	!>
3827	!> @author J.Paul
3828	!> @date November, 2013 - Initial version
3829	!>
3830	!> @param[inout] td_mpp mpp strcuture
3831	!-------------------------------------------------------------------
3832
3833	IMPLICIT NONE
3834
3835	! Argument
3836	TYPE(TMPP), INTENT(INOUT) :: td_mpp
3837
3838	! local variable
3839	INTEGER(i4) :: il_isize
3840	INTEGER(i4) :: il_jsize
3841	!----------------------------------------------------------------
3842
3843	IF( ASSOCIATED(td_mpp%t_proc) )THEN
3844
3845	IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_njproc == 0 )THEN
3846	CALL logger_info("MPP GET DOM: use indoor indices to get domain "//&
3847	& "decomposition type.")
3848	IF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
3849	& td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1) .AND. &
3850	& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
3851	& td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1) )THEN
3852
3853	td_mpp%c_dom='nooverlap'
3854
3855	ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
3856	& td_mpp%t_proc(1)%i_lci ) .AND. &
3857	& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
3858	& td_mpp%t_proc(1)%i_lcj ) )THEN
3859
3860	td_mpp%c_dom='noextra'
3861
3862	ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == &
3863	& td_mpp%t_dim(1)%i_len ) .AND. &
3864	& (td_mpp%t_proc(1)%t_dim(2)%i_len == &
3865	& td_mpp%t_dim(2)%i_len ) )THEN
3866
3867	td_mpp%c_dom='full'
3868
3869	ELSE
3870
3871	CALL logger_error("MPP GET DOM: should have been an impossible case")
3872
3873	il_isize=td_mpp%t_proc(1)%t_dim(1)%i_len
3874	il_jsize=td_mpp%t_proc(1)%t_dim(2)%i_len
3875	CALL logger_debug("MPP GET DOM: proc size "//&
3876	& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
3877
3878	il_isize=td_mpp%t_proc(1)%i_lei - td_mpp%t_proc(1)%i_ldi + 1
3879	il_jsize=td_mpp%t_proc(1)%i_lej - td_mpp%t_proc(1)%i_ldj + 1
3880	CALL logger_debug("MPP GET DOM: no overlap size "//&
3881	& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
3882
3883	il_isize=td_mpp%t_proc(1)%i_lci
3884	il_jsize=td_mpp%t_proc(1)%i_lcj
3885	CALL logger_debug("MPP GET DOM: overlap size "//&
3886	& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
3887
3888	il_isize=td_mpp%t_dim(1)%i_len
3889	il_jsize=td_mpp%t_dim(2)%i_len
3890	CALL logger_debug("MPP GET DOM: full size "//&
3891	& TRIM(fct_str(il_isize))//" x "//TRIM(fct_str(il_jsize)) )
3892
3893	ENDIF
3894
3895	ELSE
3896
3897	CALL logger_info("MPP GET DOM: use number of processors following "//&
3898	& "I and J to get domain decomposition type.")
3899	IF( td_mpp%i_niproc*td_mpp%i_njproc==td_mpp%i_nproc )THEN
3900	IF( td_mpp%i_nproc == 1 )THEN
3901	td_mpp%c_dom='full'
3902	ENDIF
3903	td_mpp%c_dom='nooverlap'
3904	ELSE
3905	td_mpp%c_dom='noextra'
3906	ENDIF
3907
3908	ENDIF
3909
3910	ELSE
3911	CALL logger_error("MPP GET DOM: domain decomposition not define.")
3912	ENDIF
3913
3914	END SUBROUTINE mpp_get_dom
3915	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3916	FUNCTION mpp__check_var_dim(td_mpp, td_var) &
3917	& RESULT(lf_check)
3918	!-------------------------------------------------------------------
3919	!> @brief This function check if variable and mpp structure use same
3920	!> dimension.
3921	!>
3922	!> @details
3923	!>
3924	!> @author J.Paul
3925	!> @date November, 2013 - Initial Version
3926	!> @date September 2015
3927	!> - do not check used dimension here
3928	!>
3929	!> @param[in] td_mpp mpp structure
3930	!> @param[in] td_var variable structure
3931	!> @return dimension of variable and mpp structure agree (or not)
3932	!-------------------------------------------------------------------
3933
3934	IMPLICIT NONE
3935
3936	! Argument
3937	TYPE(TMPP), INTENT(IN) :: td_mpp
3938	TYPE(TVAR), INTENT(IN) :: td_var
3939
3940	! function
3941	LOGICAL :: lf_check
3942
3943	! local variable
3944	CHARACTER(LEN=lc) :: cl_dim
3945	LOGICAL :: ll_error
3946	LOGICAL :: ll_warn
3947
3948	INTEGER(i4) :: il_ind
3949
3950	! loop indices
3951	INTEGER(i4) :: ji
3952	!----------------------------------------------------------------
3953
3954	lf_check=.TRUE.
3955
3956	! check used dimension
3957	ll_error=.FALSE.
3958	ll_warn=.FALSE.
3959	DO ji=1,ip_maxdim
3960	il_ind=dim_get_index( td_mpp%t_dim(:), &
3961	& TRIM(td_var%t_dim(ji)%c_name), &
3962	& TRIM(td_var%t_dim(ji)%c_sname))
3963	IF( il_ind /= 0 )THEN
3964	IF( td_var%t_dim(ji)%l_use .AND. &
3965	&td_mpp%t_dim(il_ind)%l_use .AND. &
3966	&td_var%t_dim(ji)%i_len /= td_mpp%t_dim(il_ind)%i_len )THEN
3967	IF( INDEX( TRIM(td_var%c_axis), &
3968	& TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN
3969	ll_warn=.TRUE.
3970	ELSE
3971	ll_error=.TRUE.
3972	ENDIF
3973	ENDIF
3974	ENDIF
3975	ENDDO
3976
3977	IF( ll_error )THEN
3978
3979	cl_dim='(/'
3980	DO ji = 1, td_mpp%i_ndim
3981	IF( td_mpp%t_dim(ji)%l_use )THEN
3982	cl_dim=TRIM(cl_dim)//&
3983	& TRIM(fct_upper(td_mpp%t_dim(ji)%c_sname))//':'//&
3984	& TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//','
3985	ENDIF
3986	ENDDO
3987	cl_dim=TRIM(cl_dim)//'/)'
3988	CALL logger_debug( " mpp dimension: "//TRIM(cl_dim) )
3989
3990	cl_dim='(/'
3991	DO ji = 1, td_var%i_ndim
3992	IF( td_var%t_dim(ji)%l_use )THEN
3993	cl_dim=TRIM(cl_dim)//&
3994	& TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//&
3995	& TRIM(fct_str(td_var%t_dim(ji)%i_len))//','
3996	ENDIF
3997	ENDDO
3998	cl_dim=TRIM(cl_dim)//'/)'
3999	CALL logger_debug( " variable dimension: "//TRIM(cl_dim) )
4000
4001	lf_check=.FALSE.
4002
4003	CALL logger_error( &
4004	& " MPP CHECK VAR DIM: variable and file dimension differ"//&
4005	& " for variable "//TRIM(td_var%c_name)//&
4006	& " and file "//TRIM(td_mpp%c_name))
4007
4008	ELSEIF( ll_warn )THEN
4009	CALL logger_warn( &
4010	& " MPP CHECK VAR DIM: variable and file dimension differ"//&
4011	& " for variable "//TRIM(td_var%c_name)//&
4012	& " and file "//TRIM(td_mpp%c_name)//". you should use"//&
4013	& " var_check_dim to remove useless dimension.")
4014	ELSE
4015
4016	IF( td_var%i_ndim > td_mpp%i_ndim )THEN
4017	CALL logger_info("MPP CHECK VAR DIM: variable "//&
4018	& TRIM(td_var%c_name)//" use more dimension than file "//&
4019	& TRIM(td_mpp%c_name)//" do until now.")
4020	ENDIF
4021
4022	ENDIF
4023
4024	END FUNCTION mpp__check_var_dim
4025	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4026	FUNCTION mpp_get_index(td_mpp, cd_name) &
4027	& RESULT(if_idx)
4028	!-------------------------------------------------------------------
4029	!> @brief This function return the mpp id, in a array of mpp
4030	!> structure, given mpp base name.
4031	!>
4032	!> @author J.Paul
4033	!> @date November, 2013 - Initial Version
4034	!>
4035	!> @param[in] td_file array of file structure
4036	!> @param[in] cd_name file name
4037	!> @return file id in array of file structure (0 if not found)
4038	!-------------------------------------------------------------------
4039
4040	IMPLICIT NONE
4041
4042	! Argument
4043	TYPE(TMPP) , DIMENSION(:), INTENT(IN) :: td_mpp
4044	CHARACTER(LEN=*), INTENT(IN) :: cd_name
4045
4046	! function
4047	INTEGER(i4) :: if_idx
4048
4049	! local variable
4050	CHARACTER(LEN=lc) :: cl_name
4051	INTEGER(i4) :: il_size
4052
4053	! loop indices
4054	INTEGER(i4) :: ji
4055	!----------------------------------------------------------------
4056	if_idx=0
4057	il_size=SIZE(td_mpp(:))
4058
4059	cl_name=TRIM( file_rename(cd_name) )
4060
4061	! check if mpp is in array of mpp structure
4062	DO ji=1,il_size
4063	! look for file name
4064	IF( TRIM(fct_lower(td_mpp(ji)%c_name)) == TRIM(fct_lower(cd_name)) )THEN
4065
4066	if_idx=ji
4067	EXIT
4068
4069	ENDIF
4070	ENDDO
4071
4072	END FUNCTION mpp_get_index
4073	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4074	FUNCTION mpp_recombine_var(td_mpp, cd_name) &
4075	& RESULT(tf_var)
4076	!-------------------------------------------------------------------
4077	!> @brief This function recombine variable splitted in mpp structure.
4078	!>
4079	!> @author J.Paul
4080	!> @date October, 2014 - Initial Version
4081	!>
4082	!> @param[in] td_mpp mpp file structure
4083	!> @param[in] cd_name variable name
4084	!> @return variable strucutre
4085	!-------------------------------------------------------------------
4086
4087	IMPLICIT NONE
4088
4089	! Argument
4090	TYPE(TMPP) , INTENT(IN) :: td_mpp
4091	CHARACTER(LEN=*), INTENT(IN) :: cd_name
4092	! function
4093	TYPE(TVAR) :: tf_var
4094
4095	! local variable
4096	INTEGER(i4) :: il_varid
4097	INTEGER(i4) :: il_status
4098	INTEGER(i4) :: il_i1p
4099	INTEGER(i4) :: il_i2p
4100	INTEGER(i4) :: il_j1p
4101	INTEGER(i4) :: il_j2p
4102	INTEGER(i4), DIMENSION(4) :: il_ind
4103
4104	INTEGER(i4), DIMENSION(ip_maxdim) :: il_strt
4105	INTEGER(i4), DIMENSION(ip_maxdim) :: il_cnt
4106
4107	TYPE(TVAR) :: tl_tmp
4108
4109	! loop indices
4110	INTEGER(i4) :: ji
4111	INTEGER(i4) :: jk
4112	!----------------------------------------------------------------
4113
4114	il_varid=var_get_index( td_mpp%t_proc(1)%t_var(:), cd_name)
4115	IF( il_varid /= 0 )THEN
4116
4117	tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid))
4118	! Allocate space to hold variable value in structure
4119	IF( ASSOCIATED(tf_var%d_value) )THEN
4120	DEALLOCATE(tf_var%d_value)
4121	ENDIF
4122	!
4123	DO ji=1,ip_maxdim
4124	IF( tf_var%t_dim(ji)%l_use )THEN
4125	tf_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len
4126	ENDIF
4127	ENDDO
4128
4129	ALLOCATE(tf_var%d_value( tf_var%t_dim(1)%i_len, &
4130	& tf_var%t_dim(2)%i_len, &
4131	& tf_var%t_dim(3)%i_len, &
4132	& tf_var%t_dim(4)%i_len),&
4133	& stat=il_status)
4134	IF(il_status /= 0 )THEN
4135
4136	CALL logger_error( &
4137	& " MPP RECOMBINE VAR: not enough space to put variable "//&
4138	& TRIM(tf_var%c_name)//" in variable structure")
4139
4140	ENDIF
4141
4142	! FillValue by default
4143	tf_var%d_value(:,:,:,:)=tf_var%d_fill
4144
4145	! read processor
4146	DO jk=1,td_mpp%i_nproc
4147	IF( td_mpp%t_proc(jk)%l_use )THEN
4148	! get processor indices
4149	il_ind(:)=mpp_get_proc_index( td_mpp, jk )
4150	il_i1p = il_ind(1)
4151	il_i2p = il_ind(2)
4152	il_j1p = il_ind(3)
4153	il_j2p = il_ind(4)
4154
4155	il_strt(:)=(/ 1,1,1,1 /)
4156
4157	il_cnt(:)=(/ il_i2p-il_i1p+1, &
4158	& il_j2p-il_j1p+1, &
4159	& tf_var%t_dim(3)%i_len, &
4160	& tf_var%t_dim(4)%i_len /)
4161
4162	tl_tmp=iom_read_var( td_mpp%t_proc(jk), tf_var%c_name,&
4163	& il_strt(:), il_cnt(:) )
4164
4165	! replace value in output variable structure
4166	tf_var%d_value( il_i1p : il_i2p, &
4167	& il_j1p : il_j2p, &
4168	& :,:) = tl_tmp%d_value(:,:,:,:)
4169
4170	! clean
4171	CALL var_clean(tl_tmp)
4172
4173	ENDIF
4174	ENDDO
4175
4176	ELSE
4177
4178	CALL logger_error( &
4179	& " MPP RECOMBINE VAR: there is no variable with "//&
4180	& "name or standard name"//TRIM(cd_name)//&
4181	& " in mpp file "//TRIM(td_mpp%c_name))
4182	ENDIF
4183
4184	END FUNCTION mpp_recombine_var
4185	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4186	SUBROUTINE mpp__read_halo(td_file, td_dimglo)
4187	!-------------------------------------------------------------------
4188	!> @brief This subroutine read subdomain indices defined with halo
4189	!> (NEMO netcdf way)
4190	!>
4191	!> @author J.Paul
4192	!> @date January, 2016 - Initial Version
4193	!>
4194	!> @param[inout] td_file mpp structure
4195	!-------------------------------------------------------------------
4196
4197	IMPLICIT NONE
4198
4199	! Argument
4200	TYPE(TFILE) , INTENT(INOUT) :: td_file
4201	TYPE(TDIM) , DIMENSION(:), INTENT(IN ) :: td_dimglo
4202
4203	! local variable
4204	INTEGER(i4) :: il_attid
4205	INTEGER(i4) :: il_ifirst
4206	INTEGER(i4) :: il_jfirst
4207	INTEGER(i4) :: il_ilast
4208	INTEGER(i4) :: il_jlast
4209	INTEGER(i4) :: il_ihalostart
4210	INTEGER(i4) :: il_jhalostart
4211	INTEGER(i4) :: il_ihaloend
4212	INTEGER(i4) :: il_jhaloend
4213
4214	CHARACTER(LEN=lc) :: cl_dom
4215	!----------------------------------------------------------------
4216
4217	! DOMAIN_position_first
4218	il_attid = 0
4219	IF( ASSOCIATED(td_file%t_att) )THEN
4220	il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" )
4221	ENDIF
4222	IF( il_attid /= 0 )THEN
4223	il_ifirst = INT(td_file%t_att(il_attid)%d_value(1))
4224	il_jfirst = INT(td_file%t_att(il_attid)%d_value(2))
4225	ELSE
4226	il_ifirst = 1
4227	il_jfirst = 1
4228	ENDIF
4229
4230	! DOMAIN_position_last
4231	il_attid = 0
4232	IF( ASSOCIATED(td_file%t_att) )THEN
4233	il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" )
4234	ENDIF
4235	IF( il_attid /= 0 )THEN
4236	il_ilast = INT(td_file%t_att(il_attid)%d_value(1))
4237	il_jlast = INT(td_file%t_att(il_attid)%d_value(2))
4238	ELSE
4239	il_ilast = td_file%t_dim(1)%i_len
4240	il_jlast = td_file%t_dim(2)%i_len
4241	ENDIF
4242
4243	! DOMAIN_halo_size_start
4244	il_attid = 0
4245	IF( ASSOCIATED(td_file%t_att) )THEN
4246	il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" )
4247	ENDIF
4248	IF( il_attid /= 0 )THEN
4249	il_ihalostart = INT(td_file%t_att(il_attid)%d_value(1))
4250	il_jhalostart = INT(td_file%t_att(il_attid)%d_value(2))
4251	ELSE
4252	il_ihalostart = 0
4253	il_jhalostart = 0
4254	ENDIF
4255
4256	! DOMAIN_halo_size_end
4257	il_attid = 0
4258	IF( ASSOCIATED(td_file%t_att) )THEN
4259	il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" )
4260	ENDIF
4261	IF( il_attid /= 0 )THEN
4262	il_ihaloend = INT(td_file%t_att(il_attid)%d_value(1))
4263	il_jhaloend = INT(td_file%t_att(il_attid)%d_value(2))
4264	ELSE
4265	il_ihaloend = 0
4266	il_jhaloend = 0
4267	ENDIF
4268
4269	IF( (td_dimglo(jp_I)%i_len == td_file%t_dim(jp_I)%i_len) .AND. &
4270	& (td_dimglo(jp_J)%i_len == td_file%t_dim(jp_J)%i_len) )THEN
4271	cl_dom='full'
4272	ELSEIF( il_ihalostart == 0 .AND. il_jhalostart == 0 .AND. &
4273	& il_ihaloend == 0 .AND. il_jhaloend == 0 )THEN
4274	cl_dom='nooverlap'
4275	ELSE
4276	cl_dom='noextra'
4277	ENDIF
4278
4279	SELECT CASE(TRIM(cl_dom))
4280	CASE('full')
4281	td_file%i_impp = il_ifirst
4282	td_file%i_jmpp = il_jfirst
4283	td_file%i_lci = td_file%t_dim(jp_I)%i_len
4284	td_file%i_lcj = td_file%t_dim(jp_J)%i_len
4285	td_file%i_ldi = il_ihalostart + 1
4286	td_file%i_ldj = il_jhalostart + 1
4287	td_file%i_lei = td_file%t_dim(jp_I)%i_len - il_ihaloend
4288	td_file%i_lej = td_file%t_dim(jp_J)%i_len - il_jhaloend
4289	CASE('noextra')
4290	td_file%i_impp = il_ifirst
4291	td_file%i_jmpp = il_jfirst
4292	td_file%i_lci = td_file%t_dim(jp_I)%i_len
4293	td_file%i_lcj = td_file%t_dim(jp_J)%i_len
4294	td_file%i_ldi = il_ihalostart + 1
4295	td_file%i_ldj = il_jhalostart + 1
4296	td_file%i_lei = td_file%i_lci - il_ihaloend
4297	td_file%i_lej = td_file%i_lcj - il_jhaloend
4298	CASE('nooverlap') !!!?????
4299	td_file%i_impp = il_ifirst
4300	td_file%i_jmpp = il_jfirst
4301	td_file%i_lci = td_file%t_dim(jp_I)%i_len
4302	td_file%i_lcj = td_file%t_dim(jp_J)%i_len
4303	td_file%i_ldi = 1
4304	td_file%i_ldj = 1
4305	td_file%i_lei = td_file%t_dim(jp_I)%i_len
4306	td_file%i_lej = td_file%t_dim(jp_J)%i_len
4307	END SELECT
4308
4309	END SUBROUTINE mpp__read_halo
4310	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4311	SUBROUTINE mpp__compute_halo(td_mpp)
4312	!-------------------------------------------------------------------
4313	!> @brief This subroutine compute subdomain indices defined with halo
4314	!> (NEMO netcdf way)
4315	!>
4316	!> @author J.Paul
4317	!> @date January, 2016 - Initial Version
4318	!>
4319	!> @param[inout] td_mpp mpp structure
4320	!-------------------------------------------------------------------
4321
4322	IMPLICIT NONE
4323
4324	! Argument
4325	TYPE(TMPP) , INTENT(INOUT) :: td_mpp
4326
4327	! local variable
4328	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ifirst
4329	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jfirst
4330	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ilast
4331	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jlast
4332	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihalostart
4333	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhalostart
4334	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihaloend
4335	INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhaloend
4336
4337	TYPE(TATT) :: tl_att
4338
4339	! loop indices
4340	INTEGER(i4) :: ji
4341	!----------------------------------------------------------------
4342
4343	ALLOCATE( il_ifirst (td_mpp%i_nproc) )
4344	ALLOCATE( il_jfirst (td_mpp%i_nproc) )
4345
4346	ALLOCATE( il_ilast (td_mpp%i_nproc) )
4347	ALLOCATE( il_jlast (td_mpp%i_nproc) )
4348
4349	ALLOCATE( il_ihalostart(td_mpp%i_nproc) )
4350	ALLOCATE( il_jhalostart(td_mpp%i_nproc) )
4351
4352	ALLOCATE( il_ihaloend (td_mpp%i_nproc) )
4353	ALLOCATE( il_jhaloend (td_mpp%i_nproc) )
4354
4355	SELECT CASE(TRIM(td_mpp%c_dom))
4356	CASE('full')
4357
4358	il_ifirst(:)=td_mpp%t_proc(:)%i_impp
4359	il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp
4360
4361	il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%t_dim(jp_I)%i_len - 1
4362	il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%t_dim(jp_J)%i_len - 1
4363
4364	il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1
4365	il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1
4366
4367	il_ihaloend(:)=td_mpp%t_proc(:)%t_dim(jp_I)%i_len - td_mpp%t_proc(:)%i_lei
4368	il_jhaloend(:)=td_mpp%t_proc(:)%t_dim(jp_J)%i_len - td_mpp%t_proc(:)%i_lej
4369
4370	CASE('noextra')
4371
4372	il_ifirst(:)=td_mpp%t_proc(:)%i_impp
4373	il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp
4374
4375	il_ilast(:) =td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lci - 1
4376	il_jlast(:) =td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lcj - 1
4377
4378	il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1
4379	il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1
4380
4381	il_ihaloend(:)=td_mpp%t_proc(:)%i_lci - td_mpp%t_proc(:)%i_lei
4382	il_jhaloend(:)=td_mpp%t_proc(:)%i_lcj - td_mpp%t_proc(:)%i_lej
4383
4384	CASE('nooverlap')
4385
4386	il_ifirst(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_ldi - 1
4387	il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_ldj - 1
4388
4389	il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lei - 1
4390	il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lej - 1
4391
4392	il_ihalostart(:)=0
4393	il_jhalostart(:)=0
4394
4395	il_ihaloend(:)=0
4396	il_jhaloend(:)=0
4397
4398	CASE DEFAULT
4399	CALL logger_fatal("MPP INIT: invalid "//&
4400	& "decomposition type.")
4401	END SELECT
4402
4403	DO ji=1,td_mpp%i_nproc
4404	tl_att=att_init( "DOMAIN_position_first", &
4405	& (/ il_ifirst(ji), il_jfirst(ji) /) )
4406	CALL file_move_att(td_mpp%t_proc(ji), tl_att)
4407
4408	tl_att=att_init( "DOMAIN_position_last", &
4409	& (/ il_ilast(ji), il_jlast(ji) /) )
4410	CALL file_move_att(td_mpp%t_proc(ji), tl_att)
4411
4412	tl_att=att_init( "DOMAIN_halo_size_start", &
4413	& (/ il_ihalostart(ji), il_jhalostart(ji) /) )
4414	CALL file_move_att( td_mpp%t_proc(ji), tl_att)
4415
4416	tl_att=att_init( "DOMAIN_halo_size_end", &
4417	& (/ il_ihaloend(ji), il_jhaloend(ji) /) )
4418	CALL file_move_att( td_mpp%t_proc(ji), tl_att)
4419	ENDDO
4420
4421	DEALLOCATE( il_ifirst )
4422	DEALLOCATE( il_jfirst )
4423
4424	DEALLOCATE( il_ilast )
4425	DEALLOCATE( il_jlast )
4426
4427	DEALLOCATE( il_ihalostart)
4428	DEALLOCATE( il_jhalostart)
4429
4430	DEALLOCATE( il_ihaloend )
4431	DEALLOCATE( il_jhaloend )
4432
4433	!impp
4434	tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", td_mpp%t_proc(:)%i_impp)
4435	CALL mpp_move_att(td_mpp, tl_att)
4436
4437	tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", td_mpp%t_proc(:)%i_jmpp)
4438	CALL mpp_move_att(td_mpp, tl_att)
4439
4440	! lci
4441	tl_att=att_init( "SUBDOMAIN_I_dimensions", td_mpp%t_proc(:)%i_lci)
4442	CALL mpp_move_att(td_mpp, tl_att)
4443
4444	tl_att=att_init( "SUBDOMAIN_J_dimensions", td_mpp%t_proc(:)%i_lcj)
4445	CALL mpp_move_att(td_mpp, tl_att)
4446
4447	! ldi
4448	tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", td_mpp%t_proc(:)%i_ldi)
4449	CALL mpp_move_att(td_mpp, tl_att)
4450
4451	tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", td_mpp%t_proc(:)%i_ldj)
4452	CALL mpp_move_att(td_mpp, tl_att)
4453
4454	! lei
4455	tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", td_mpp%t_proc(:)%i_lei)
4456	CALL mpp_move_att(td_mpp, tl_att)
4457
4458	tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", td_mpp%t_proc(:)%i_lej)
4459	CALL mpp_move_att(td_mpp, tl_att)
4460
4461	! clean
4462	CALL att_clean(tl_att)
4463
4464	END SUBROUTINE mpp__compute_halo
4465	!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4466	END MODULE mpp
4467

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

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

Context Navigation

source: utils/tools/SIREN/src/mpp.f90 @ 13369

Download in other formats: