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

Last change on this file since 12080 was 12080, checked in by jpaul, 10 months ago

update nemo trunk

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