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/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/2014/dev_r4650_UKMO14.12_STAND_ALONE_OBSOPER/NEMOGCM/TOOLS/SIREN/src/mpp.f90 @ 6043

Last change on this file since 6043 was 6043, checked in by timgraham, 8 years ago

Merged head of trunk into branch

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