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 NEMO/trunk/tools/SIREN/src – NEMO

source: NEMO/trunk/tools/SIREN/src/mpp.f90 @ 9598

Last change on this file since 9598 was 9598, checked in by nicolasmartin, 6 years ago

Reorganisation plan for NEMO repository: changes to make compilation succeed with new structure
Juste one issue left with AGRIF_NORDIC with AGRIF preprocessing
Standardisation of routines header with version 4.0 and year 2018
Fix for some broken symlinks

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