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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

mpp.f90 in branches/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: branches/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src/mpp.f90 @ 4213

Last change on this file since 4213 was 4213, checked in by cbricaud, 10 years ago
first draft of the CONFIGURATION MANAGER demonstrator
File size: 110.5 KB

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

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

Download in other formats: