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

Last change on this file since 5600 was 5600, checked in by andrewryan, 5 years ago

merged in latest version of trunk alongside changes to SAO_SRC to be compatible with latest OBS

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