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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
file.f90 in branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/TOOLS/SIREN/src/file.f90 @ 5682

Last change on this file since 5682 was 5682, checked in by mattmartin, 9 years ago

OBS simplification changes committed to branch after running SETTE tests to make sure we get the same results as the trunk for ORCA2_LIM_OBS.

File size: 72.8 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! MODULE: file
6!
7!> @brief
8!> This module manage file structure.
9!>
10!> @details
11!>    define type TFILE:<br/>
12!> @code
13!>    TYPE(TFILE) :: tl_file
14!> @endcode
15!>
16!>    to initialize a file structure:<br/>
17!> @code
18!>    tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,cd_grid])
19!%    tl_file=file_init(cd_file [,cd_type] [,ld_wrt] [,id_ew] [,id_perio] [,id_pivot] [,cd_grid])
20!> @endcode
21!>       - cd_file is the file name
22!>       - cd_type is the type of the file ('cdf', 'dimg') [optional]
23!>       - ld_wrt  file in write mode or not [optional]
24!%       - id_ew is the number of point for east-west overlap [optional]
25!%       - id_perio is the NEMO periodicity index [optional]
26!%       - id_pivot is the NEMO pivot point index F(0),T(1) [optional]
27!>       - cd_grid is the grid type (default 'ARAKAWA-C')
28!>
29!>    to get file name:<br/>
30!>    - tl_file\%c_name
31!>
32!>    to get file id (units):<br/>
33!>    - tl_file\%i_id
34!>   
35!>    to get the type of the file (cdf, cdf4, dimg):<br/>
36!>    - tl_file\%c_type
37!>
38!>    to know if file was open in write mode:<br/>
39!>    - tl_file\%l_wrt
40!>
41!>    to get the record length of the file:<br/>
42!>    - tl_file\%i_recl
43!>
44!>    Files variables<br/>
45!>    to get the number of variable in the file:<br/>
46!>    - tl_file\%i_nvar
47!>
48!>    to get the array of variable structure associated to the file:<br/>
49!>    - tl_file\%t_var(:)
50!>
51!>    Files attributes<br/>
52!>    to get the nmber of global attributes of the file:<br/>
53!>    - tl_file\%i_natt
54!>
55!>    to get the array of attributes structure associated to the file:<br/>
56!>    - tl_file\%t_att(:)
57!>
58!>    Files dimensions<br/>
59!>    to get the number of dimension used in the file:<br/>
60!>    - tl_file\%i_ndim
61!>
62!>    to get the array of dimension structure (4 elts) associated to the
63!>    file:<br/>
64!>    - tl_file\%t_dim(:)
65!>
66!>    to print information about file structure:<br/>
67!> @code
68!>    CALL file_print(td_file)
69!> @endcode
70!>
71!>    to clean file structure:<br/>
72!> @code
73!>    CALL file_clean(td_file)
74!> @endcode
75!>
76!>    to add a global attribute structure in file structure:<br/>
77!> @code
78!>    CALL file_add_att(td_file, td_att)
79!> @endcode
80!>       - td_att is an attribute structure
81!>
82!>    to add a dimension structure in file structure:<br/>
83!> @code
84!>    CALL file_add_dim(td_file, td_dim)
85!> @endcode
86!>       - td_dim is a dimension structure
87!>
88!>    to add a variable structure in file structure:<br/>
89!> @code
90!>    CALL file_add_var(td_file, td_var)
91!> @endcode
92!>       - td_var is a variable structure
93!>
94!>    to delete a global attribute structure in file structure:<br/>
95!> @code
96!>    CALL file_del_att(td_file, td_att)
97!> @endcode
98!>       - td_att is an attribute structure
99!>
100!>    to delete a dimension structure in file structure:<br/>
101!> @code
102!>    CALL file_del_dim(td_file, td_dim)
103!> @endcode
104!>       - td_dim is a dimension structure
105!>
106!>    to delete a variable structure in file structure:<br/>
107!> @code
108!>    CALL file_del_var(td_file, td_var)
109!> @endcode
110!>       - td_var is a variable structure
111!>
112!>    to overwrite one attribute structure in file structure:<br/>
113!> @code
114!>    CALL file_move_att(td_file, td_att)
115!> @endcode
116!>       - td_att is an attribute structure
117!>
118!>    to  overwrite one dimension strucutre in file structure:<br/>
119!> @code
120!>    CALL file_move_dim(td_file, td_dim)
121!> @endcode
122!>       - td_dim is a dimension structure
123!>
124!>    to overwrite one variable  structure in file structure:<br/>
125!> @code
126!>    CALL file_move_var(td_file, td_var)
127!> @endcode
128!>       - td_var is a variable structure
129!>
130!>    to check if file and variable structure share same dimension:<br/>
131!> @code
132!>    ll_check_dim = file_check_var_dim(td_file, td_var)
133!> @endcode
134!>       - td_var is a variable structure
135!>
136!> @author
137!> J.Paul
138! REVISION HISTORY:
139!> @date November, 2013 - Initial Version
140!> @date November, 2014
141!> - Fix memory leaks bug
142!>
143!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
144!----------------------------------------------------------------------
145MODULE file
146   USE kind                            ! F90 kind parameter
147   USE global                          ! global variable
148   USE fct                             ! basic useful function
149   USE logger                          ! log file manager
150   USE dim                             ! dimension manager
151   USE att                             ! attribute manager
152   USE var                             ! variable manager
153   IMPLICIT NONE
154   ! NOTE_avoid_public_variables_if_possible
155
156   ! type and variable
157   PUBLIC :: TFILE   !< file structure
158
159   ! function and subroutine
160   PUBLIC :: file_copy           !< copy file structure
161   PUBLIC :: file_print          !< print information about file structure
162   PUBLIC :: file_clean          !< clean file structure
163   PUBLIC :: file_init           !< initialize file structure
164   PUBLIC :: file_add_att        !< add one attribute structure in file structure
165   PUBLIC :: file_add_var        !< add one variable  structure in file structure
166   PUBLIC :: file_add_dim        !< add one dimension strucutre in file structure
167   PUBLIC :: file_del_att        !< delete one attribute structure of file structure
168   PUBLIC :: file_del_var        !< delete one variable  structure of file structure
169   PUBLIC :: file_del_dim        !< delete one dimension strucutre of file structure
170   PUBLIC :: file_move_att       !< overwrite one attribute structure in file structure
171   PUBLIC :: file_move_var       !< overwrite one variable  structure in file structure
172   PUBLIC :: file_move_dim       !< overwrite one dimension strucutre in file structure
173   PUBLIC :: file_check_var_dim  !< check if file and variable structure use same dimension.
174   PUBLIC :: file_get_type       !< get type of file
175   PUBLIC :: file_get_id         !< get file id
176   PUBLIC :: file_rename         !< rename file name
177   PUBLIC :: file_add_suffix     !< add suffix to file name
178 
179   PRIVATE :: file__clean_unit    ! clean file structure
180   PRIVATE :: file__clean_arr     ! clean array of file structure
181   PRIVATE :: file__del_var_name ! delete a variable structure in file structure, given variable name or standard name
182   PRIVATE :: file__del_var_str  ! delete a variable structure in file structure, given variable structure
183   PRIVATE :: file__del_att_name ! delete a attribute structure in file structure, given attribute name
184   PRIVATE :: file__del_att_str  ! delete a attribute structure in file structure, given attribute structure
185   PRIVATE :: file__get_number   ! get number in file name without suffix
186   PRIVATE :: file__get_suffix   ! get suffix of file name
187   PRIVATE :: file__copy_unit    ! copy file structure
188   PRIVATE :: file__copy_arr     ! copy array of file structure
189   PRIVATE :: file__rename_char  ! rename file name, given processor number.
190   PRIVATE :: file__rename_str   ! rename file name, given file structure.
191
192   TYPE TFILE !< file structure
193
194      ! general
195      CHARACTER(LEN=lc)                 :: c_name = ""       !< file name
196      CHARACTER(LEN=lc)                 :: c_type = ""       !< type of the file (cdf, cdf4, dimg)
197      INTEGER(i4)                       :: i_id   = 0        !< file id
198      LOGICAL                           :: l_wrt  = .FALSE.  !< read or write mode
199      INTEGER(i4)                       :: i_nvar = 0        !< number of variable
200      TYPE(TVAR), DIMENSION(:), POINTER :: t_var  => NULL()  !< file variables
201
202      CHARACTER(LEN=lc)                 :: c_grid = 'ARAKAWA-C' !< grid type
203
204      INTEGER(i4)                       :: i_ew    =-1       !< east-west overlap
205      INTEGER(i4)                       :: i_perio =-1       !< NEMO periodicity index
206      INTEGER(i4)                       :: i_pivot =-1       !< NEMO pivot point index F(0),T(1)
207
208      INTEGER(i4)                       :: i_depthid = 0     !< variable id of depth
209      INTEGER(i4)                       :: i_timeid  = 0     !< variable id of time
210
211      ! netcdf file
212      INTEGER(i4)                       :: i_ndim  = 0       !< number of dimensions used in the file
213      INTEGER(i4)                       :: i_natt  = 0       !< number of global attributes in the file
214      INTEGER(i4)                       :: i_uldid = 0       !< id of the unlimited dimension in the file
215      LOGICAL                           :: l_def   = .FALSE. !< define mode or not
216      TYPE(TATT), DIMENSION(:), POINTER :: t_att   => NULL() !< global attributes
217      TYPE(TDIM), DIMENSION(ip_maxdim)  :: t_dim             !< dimension structure
218     
219      ! dimg file
220      INTEGER(i4)                       :: i_recl = 0        !< record length (binary file)
221      INTEGER(i4)                       :: i_n0d  = 0        !< number of scalar variable
222      INTEGER(i4)                       :: i_n1d  = 0        !< number of 1D variable
223      INTEGER(i4)                       :: i_n2d  = 0        !< number of 2D variable
224      INTEGER(i4)                       :: i_n3d  = 0        !< number of 3D variable
225      INTEGER(i4)                       :: i_rhd  = 0        !< record of the header infos (last record)
226
227      ! mpp
228      ! only use for massively parallel processing
229      INTEGER(i4)                       :: i_pid  = -1       !< processor id (start to 1)
230      INTEGER(i4)                       :: i_impp = 0        !< i-indexes for mpp-subdomain left bottom
231      INTEGER(i4)                       :: i_jmpp = 0        !< j-indexes for mpp-subdomain left bottom
232      INTEGER(i4)                       :: i_lci  = 0        !< i-dimensions of subdomain
233      INTEGER(i4)                       :: i_lcj  = 0        !< j-dimensions of subdomain
234      INTEGER(i4)                       :: i_ldi  = 0        !< first indoor i-indices
235      INTEGER(i4)                       :: i_ldj  = 0        !< first indoor j-indices
236      INTEGER(i4)                       :: i_lei  = 0        !< last  indoor i-indices
237      INTEGER(i4)                       :: i_lej  = 0        !< last  indoor j-indices
238
239      LOGICAL                           :: l_ctr  = .FALSE.  !< domain is on border
240      LOGICAL                           :: l_use  = .FALSE.  !< domain is used
241
242      ! only use to draw domain decomposition when initialize with mpp_init
243      INTEGER(i4)                       :: i_iind = 0        !< i-direction indices
244      INTEGER(i4)                       :: i_jind = 0        !< j-direction indices
245
246   END TYPE TFILE
247
248   INTERFACE file_clean
249      MODULE PROCEDURE file__clean_unit
250      MODULE PROCEDURE file__clean_arr
251   END INTERFACE file_clean
252
253   INTERFACE file_del_var
254      MODULE PROCEDURE file__del_var_name
255      MODULE PROCEDURE file__del_var_str
256   END INTERFACE file_del_var
257
258   INTERFACE file_del_att
259      MODULE PROCEDURE file__del_att_name
260      MODULE PROCEDURE file__del_att_str
261   END INTERFACE file_del_att
262   
263   INTERFACE file_rename
264      MODULE PROCEDURE file__rename_char
265      MODULE PROCEDURE file__rename_str
266   END INTERFACE file_rename
267
268    INTERFACE file_copy
269      MODULE PROCEDURE file__copy_unit   
270      MODULE PROCEDURE file__copy_arr   
271   END INTERFACE
272
273CONTAINS
274   !-------------------------------------------------------------------
275   !> @brief
276   !> This subroutine copy file structure in another one
277   !> @details
278   !> file variable and attribute value are copied in a temporary array,
279   !> so input and output file structure value do not point on the same
280   !> "memory cell", and so on are independant.
281   !>
282   !> @note new file is assume to be closed.
283   !>
284   !> @warning do not use on the output of a function who create or read an
285   !> structure (ex: tl_file=file_copy(file_init()) is forbidden).
286   !> This will create memory leaks.
287   !> @warning to avoid infinite loop, do not use any function inside
288   !> this subroutine
289   !>   
290   !> @author J.Paul
291   !> @date November, 2013 - Initial Version
292   !> @date November, 2014
293   !> - use function instead of overload assignment operator
294   !> (to avoid memory leak)
295   !
296   !> @param[in] td_file  file structure
297   !> @return copy of input file structure
298   !-------------------------------------------------------------------
299   FUNCTION file__copy_unit( td_file )
300      IMPLICIT NONE
301      ! Argument
302      TYPE(TFILE), INTENT(IN) :: td_file
303      ! function
304      TYPE(TFILE) :: file__copy_unit
305
306      ! local variable
307      TYPE(TVAR) :: tl_var
308      TYPE(TATT) :: tl_att
309
310      ! loop indices
311      INTEGER(i4) :: ji
312      !----------------------------------------------------------------
313
314      CALL logger_trace("FILE COPY: file "//TRIM(td_file%c_name) )
315
316      ! copy file variable
317      file__copy_unit%c_name = TRIM(td_file%c_name)
318      file__copy_unit%c_type = TRIM(td_file%c_type)
319      ! file1 should be closed even if file2 is opened right now
320      file__copy_unit%i_id   = 0
321      file__copy_unit%l_wrt  = td_file%l_wrt
322      file__copy_unit%i_nvar = td_file%i_nvar
323
324      file__copy_unit%c_grid = td_file%c_grid
325
326      file__copy_unit%i_ew   = td_file%i_ew
327      file__copy_unit%i_perio= td_file%i_perio
328      file__copy_unit%i_pivot= td_file%i_pivot
329
330      file__copy_unit%i_depthid = td_file%i_depthid
331      file__copy_unit%i_timeid  = td_file%i_timeid
332
333      ! copy variable structure
334      IF( ASSOCIATED(file__copy_unit%t_var) )THEN
335         CALL var_clean(file__copy_unit%t_var(:))
336         DEALLOCATE(file__copy_unit%t_var)
337      ENDIF
338      IF( ASSOCIATED(td_file%t_var) .AND. file__copy_unit%i_nvar > 0 )THEN
339         ALLOCATE( file__copy_unit%t_var(file__copy_unit%i_nvar) )
340         DO ji=1,file__copy_unit%i_nvar
341            tl_var = var_copy(td_file%t_var(ji))
342            file__copy_unit%t_var(ji) = var_copy(tl_var)
343         ENDDO
344      ENDIF
345     
346      ! copy netcdf variable
347      file__copy_unit%i_ndim   = td_file%i_ndim
348      file__copy_unit%i_natt   = td_file%i_natt
349      file__copy_unit%i_uldid  = td_file%i_uldid
350      file__copy_unit%l_def    = td_file%l_def
351
352      ! copy dimension
353      file__copy_unit%t_dim(:) = dim_copy(td_file%t_dim(:))
354     
355      ! copy attribute structure
356      IF( ASSOCIATED(file__copy_unit%t_att) )THEN
357         CALL att_clean(file__copy_unit%t_att(:))
358         DEALLOCATE(file__copy_unit%t_att)
359      ENDIF
360      IF( ASSOCIATED(td_file%t_att) .AND. file__copy_unit%i_natt > 0 )THEN
361         ALLOCATE( file__copy_unit%t_att(file__copy_unit%i_natt) )
362         DO ji=1,file__copy_unit%i_natt
363            tl_att = att_copy(td_file%t_att(ji))
364            file__copy_unit%t_att(ji) = att_copy(tl_att)
365         ENDDO
366      ENDIF
367
368      ! clean
369      CALL att_clean(tl_att)
370
371      ! copy dimg variable
372      file__copy_unit%i_recl = td_file%i_recl
373      file__copy_unit%i_n0d  = td_file%i_n0d
374      file__copy_unit%i_n1d  = td_file%i_n1d
375      file__copy_unit%i_n2d  = td_file%i_n2d
376      file__copy_unit%i_n3d  = td_file%i_n3d 
377      file__copy_unit%i_rhd  = td_file%i_rhd
378     
379      ! copy mpp variable
380      file__copy_unit%i_pid  = td_file%i_pid
381      file__copy_unit%i_impp = td_file%i_impp
382      file__copy_unit%i_jmpp = td_file%i_jmpp
383      file__copy_unit%i_lci  = td_file%i_lci
384      file__copy_unit%i_lcj  = td_file%i_lcj
385      file__copy_unit%i_ldi  = td_file%i_ldi
386      file__copy_unit%i_ldj  = td_file%i_ldj
387      file__copy_unit%i_lei  = td_file%i_lei
388      file__copy_unit%i_lej  = td_file%i_lej
389      file__copy_unit%l_ctr  = td_file%l_ctr
390      file__copy_unit%l_use  = td_file%l_use
391      file__copy_unit%i_iind = td_file%i_iind
392      file__copy_unit%i_jind = td_file%i_jind
393
394   END FUNCTION file__copy_unit
395   !-------------------------------------------------------------------
396   !> @brief
397   !> This subroutine copy a array of file structure in another one
398   !> @details
399   !> file variable and attribute value are copied in a temporary array,
400   !> so input and output file structure value do not point on the same
401   !> "memory cell", and so on are independant.
402   !>
403   !> @note new file is assume to be closed.
404   !>
405   !> @warning do not use on the output of a function who create or read an
406   !> structure (ex: tl_file=file_copy(file_init()) is forbidden).
407   !> This will create memory leaks.
408   !> @warning to avoid infinite loop, do not use any function inside
409   !> this subroutine
410   !>   
411   !> @author J.Paul
412   !> @date November, 2013 - Initial Version
413   !> @date November, 2014
414   !> - use function instead of overload assignment operator
415   !> (to avoid memory leak)
416   !
417   !> @param[in] td_file  file structure
418   !> @return copy of input array of file structure
419   !-------------------------------------------------------------------
420   FUNCTION file__copy_arr( td_file )
421      IMPLICIT NONE
422      ! Argument
423      TYPE(TFILE), DIMENSION(:)                , INTENT(IN   ) :: td_file
424      ! function
425      TYPE(TFILE), DIMENSION(SIZE(td_file(:))) :: file__copy_arr
426
427      ! loop indices
428      INTEGER(i4) :: ji
429      !----------------------------------------------------------------
430
431      DO ji=1,SIZE(td_file(:))
432         file__copy_arr(ji)=file_copy(td_file(ji))
433      ENDDO
434
435   END FUNCTION file__copy_arr
436   !-------------------------------------------------------------------
437   !> @brief This function initialize file structure.<br/>
438   !> @details
439   !> If cd_type is not specify, check if file name include '.nc' or
440   !> '.dimg'<br/>
441   !> Optionally, you could specify:<br/>
442   !> - write mode (default .FALSE., ld_wrt)
443   !% - East-West overlap (id_ew)
444   !% - NEMO periodicity index (id_perio)
445   !% - NEMO pivot point index F(0),T(1) (id_pivot)
446   !> - grid type (default: 'ARAKAWA-C')
447   !
448   !> @details
449   !
450   !> @author J.Paul
451   !> @date November, 2013 - Initial Version
452   !
453   !> @param[in] cd_file   file name
454   !> @param[in] cd_type   file type ('cdf', 'dimg')
455   !> @param[in] ld_wrt    write mode (default .FALSE.)
456   !> @param[in] id_ew     east-west overlap
457   !> @param[in] id_perio  NEMO periodicity index
458   !> @param[in] id_pivot  NEMO pivot point index F(0),T(1)
459   !> @param[in] cd_grid   grid type (default 'ARAKAWA-C')
460   !> @return file structure
461   !-------------------------------------------------------------------
462   TYPE(TFILE) FUNCTION file_init( cd_file, cd_type, ld_wrt, &
463   &                               id_ew, id_perio, id_pivot,&
464   &                               cd_grid)
465      IMPLICIT NONE
466      ! Argument     
467      CHARACTER(LEN=*), INTENT(IN) :: cd_file
468      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type
469      LOGICAL         , INTENT(IN), OPTIONAL :: ld_wrt
470      INTEGER(i4)     , INTENT(IN), OPTIONAL :: id_ew
471      INTEGER(i4)     , INTENT(IN), OPTIONAL :: id_perio
472      INTEGER(i4)     , INTENT(IN), OPTIONAL :: id_pivot
473      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_grid
474
475      ! local variable
476      TYPE(TATT)  :: tl_att
477      !----------------------------------------------------------------
478
479      ! clean file
480      CALL file_clean(file_init)
481
482      file_init%c_name=TRIM(ADJUSTL(cd_file))
483      CALL logger_trace("FILE INIT: initialize file "//TRIM(file_init%c_name))
484
485      ! check type
486      IF( PRESENT(cd_type) )THEN
487         SELECT CASE(TRIM(cd_type))
488            CASE('cdf')
489               file_init%c_type='cdf'
490            CASE('dimg')
491               file_init%c_type='dimg'
492            CASE DEFAULT
493               CALL logger_error( " FILE INIT: can't initialize file "//&
494               &               TRIM(file_init%c_name)//" : type unknown " )
495         END SELECT
496      ELSE
497         file_init%c_type=TRIM(file_get_type(cd_file))
498      ENDIF
499
500      ! create some global attribute
501      IF( TRIM(file_init%c_type) == 'cdf' )THEN
502         tl_att=att_init("Conventions","CF-1.5")
503         CALL file_add_att(file_init,tl_att)
504      ENDIF
505     
506      tl_att=att_init("Grid",TRIM(file_init%c_grid))
507      CALL file_add_att(file_init,tl_att)
508
509      IF( PRESENT(ld_wrt) )THEN
510         file_init%l_wrt=ld_wrt
511      ENDIF
512
513      IF( PRESENT(id_ew) )THEN
514         file_init%i_ew=id_ew
515         IF( id_ew >= 0 )THEN
516            tl_att=att_init('ew_overlap',id_ew)
517            CALL file_move_att(file_init, tl_att)
518         ENDIF
519      ENDIF
520
521      IF( PRESENT(id_perio) )THEN
522         file_init%i_perio=id_perio
523         IF( id_perio >= 0 )THEN
524            tl_att=att_init('periodicity',id_perio)
525            CALL file_move_att(file_init, tl_att)
526         ENDIF
527      ENDIF
528
529      IF( PRESENT(id_pivot) )THEN
530         file_init%i_pivot=id_pivot
531         IF( id_pivot > 0 )THEN
532            tl_att=att_init('pivot_point',id_pivot)
533            CALL file_move_att(file_init, tl_att)
534         ENDIF
535      ENDIF
536
537      IF( PRESENT(cd_grid) )THEN
538         file_init%c_grid=cd_grid
539      ENDIF
540
541      ! clean
542      CALL att_clean(tl_att)
543
544   END FUNCTION file_init
545   !-------------------------------------------------------------------
546   !> @brief
547   !> This function get type of file, given file name.
548   !> @details
549   !> Actually it get suffix of the file name, and compare it to 'nc', 'cdf' or
550   !> 'dimg'<br/>
551   !> If no suffix or suffix not identify, we assume file is dimg
552   !
553   !> @details
554   !
555   !> @author J.Paul
556   !> @date November, 2013 - Initial Version
557   !
558   !> @param[in] cd_file   file name
559   !> @return type of file
560   !-------------------------------------------------------------------
561   CHARACTER(LEN=lc) FUNCTION file_get_type(cd_file)
562      IMPLICIT NONE
563      ! Argument     
564      CHARACTER(LEN=*), INTENT(IN) :: cd_file
565
566      !local variable
567      CHARACTER(LEN=lc) :: cl_suffix
568      !----------------------------------------------------------------
569
570      cl_suffix=file__get_suffix(cd_file)
571      SELECT CASE( TRIM(fct_lower(cl_suffix)) )
572         CASE('.nc','.cdf')
573            CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is cdf")
574            file_get_type='cdf'
575         CASE('.dimg')
576            CALL logger_debug(" FILE GET TYPE: file "//TRIM(cd_file)//" is dimg" )
577            file_get_type='dimg'
578         CASE DEFAULT
579            CALL logger_warn(" FILE GET TYPE: type unknown, we assume file: "//&
580            &              TRIM(cd_file)//" is dimg ")
581            file_get_type='dimg'
582      END SELECT
583
584   END FUNCTION file_get_type
585   !-------------------------------------------------------------------
586   !> @brief This function check if variable dimension to be used
587   !> have the same length that in file structure.
588   !
589   !> @details
590   !
591   !> @author J.Paul
592   !> @date November, 2013 - Initial Version
593   !
594   !> @param[in] td_file   file structure
595   !> @param[in] td_var    variable structure
596   !> @return true if dimension of variable and file structure agree
597   !-------------------------------------------------------------------
598   LOGICAL FUNCTION file_check_var_dim(td_file, td_var)
599      IMPLICIT NONE
600      ! Argument     
601      TYPE(TFILE), INTENT(IN) :: td_file
602      TYPE(TVAR),  INTENT(IN) :: td_var
603
604      ! local variable
605      CHARACTER(LEN=lc) :: cl_dim
606      LOGICAL           :: ll_error
607      LOGICAL           :: ll_warn 
608
609      INTEGER(i4)       :: il_ind
610
611      ! loop indices
612      INTEGER(i4) :: ji
613      !----------------------------------------------------------------
614      file_check_var_dim=.TRUE.
615
616      ! check used dimension
617      ll_error=.FALSE.
618      ll_warn=.FALSE.
619      DO ji=1,ip_maxdim
620         il_ind=dim_get_index( td_file%t_dim(:), &
621         &                     TRIM(td_var%t_dim(ji)%c_name), &
622         &                     TRIM(td_var%t_dim(ji)%c_sname))
623         IF( il_ind /= 0 )THEN
624            IF( td_var%t_dim(ji)%l_use  .AND. &
625            &   td_file%t_dim(il_ind)%l_use .AND. &
626            &   td_var%t_dim(ji)%i_len /= td_file%t_dim(il_ind)%i_len )THEN
627               IF( INDEX( TRIM(td_var%c_axis), &
628               &          TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN
629                  ll_warn=.TRUE.
630               ELSE
631                  ll_error=.TRUE.
632               ENDIF
633            ENDIF
634         ENDIF
635      ENDDO
636
637      IF( ll_error )THEN
638
639         cl_dim='(/'
640         DO ji = 1, td_file%i_ndim
641            IF( td_file%t_dim(ji)%l_use )THEN
642               cl_dim=TRIM(cl_dim)//&
643               &  TRIM(fct_upper(td_file%t_dim(ji)%c_sname))//':'//&
644               &  TRIM(fct_str(td_file%t_dim(ji)%i_len))//','
645            ENDIF
646         ENDDO
647         cl_dim=TRIM(cl_dim)//'/)'
648         CALL logger_debug( " file dimension: "//TRIM(cl_dim) )
649
650         cl_dim='(/'
651         DO ji = 1, td_var%i_ndim
652            IF( td_var%t_dim(ji)%l_use )THEN
653               cl_dim=TRIM(cl_dim)//&
654               &  TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//&
655               &  TRIM(fct_str(td_var%t_dim(ji)%i_len))//','
656            ENDIF
657         ENDDO
658         cl_dim=TRIM(cl_dim)//'/)'
659         CALL logger_debug( " variable dimension: "//TRIM(cl_dim) )
660
661         file_check_var_dim=.FALSE.
662
663         CALL logger_error( &
664         &  " FILE CHECK VAR DIM: variable and file dimension differ"//&
665         &  " for variable "//TRIM(td_var%c_name)//&
666         &  " and file "//TRIM(td_file%c_name))
667
668      ELSEIF( ll_warn )THEN
669         CALL logger_warn( &
670         &  " FILE CHECK VAR DIM: variable and file dimension differ"//&
671         &  " for variable "//TRIM(td_var%c_name)//&
672         &  " and file "//TRIM(td_file%c_name)//". you should use"//&
673         &  " var_check_dim to remove useless dimension.")
674      ELSE
675
676         IF( td_var%i_ndim >  td_file%i_ndim )THEN
677            CALL logger_info("FILE CHECK VAR DIM: variable "//&
678            &  TRIM(td_var%c_name)//" use more dimension than file "//&
679            &  TRIM(td_file%c_name)//" do until now.")
680         ENDIF
681
682      ENDIF
683
684   END FUNCTION file_check_var_dim
685   !-------------------------------------------------------------------
686   !> @brief This subroutine add a variable structure in a file structure.<br/>
687   !> Do not overwrite, if variable already in file structure.
688   !
689   !> @note variable value is suppose to be ordered ('x','y','z','t')
690   !
691   !> @details
692   !
693   !> @author J.Paul
694   !> @date November, 2013 - Initial Version
695   !> @date September, 2014
696   !> - add dimension to file if need be
697   !> - do not reorder dimension from variable, before put in file
698   !
699   !> @param[inout] td_file   file structure
700   !> @param[in] td_var       variable structure
701   !-------------------------------------------------------------------
702   SUBROUTINE file_add_var(td_file, td_var)
703      IMPLICIT NONE
704
705      ! Argument     
706      TYPE(TFILE), INTENT(INOUT) :: td_file
707      TYPE(TVAR) , INTENT(IN   ) :: td_var
708
709      ! local variable
710      INTEGER(i4) :: il_status
711      !INTEGER(i4) :: il_rec
712      INTEGER(i4) :: il_ind
713
714      TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var
715
716      ! loop indices
717      INTEGER(i4) :: ji
718      !----------------------------------------------------------------
719      ! check if file opened
720      IF( TRIM(td_file%c_name) == '' )THEN
721
722         CALL logger_debug( " FILE ADD VAR: you should have used file_init before "//&
723         & "running file_add_var" )
724         CALL logger_error( " FILE ADD VAR: structure file unknown" )
725
726      ELSE
727         ! check if variable exist
728         IF( TRIM(td_var%c_name) == '' .AND. &
729         &   TRIM(td_var%c_stdname) == '' )THEN
730            CALL logger_error(" FILE ADD VAR: variable without name ")
731         ELSE
732            ! check if variable already in file structure
733            il_ind=0
734            IF( ASSOCIATED(td_file%t_var) )THEN
735               il_ind=var_get_index( td_file%t_var(:), td_var%c_name,   &
736               &                                       td_var%c_stdname )
737            ENDIF
738            CALL logger_debug( &
739            &  " FILE ADD VAR: ind "//TRIM(fct_str(il_ind)) )
740            IF( il_ind /= 0 )THEN
741
742               CALL logger_error( &
743               &  " FILE ADD VAR: variable "//TRIM(td_var%c_name)//&
744               &  ", standard name "//TRIM(td_var%c_stdname)//&
745               &  ", already in file "//TRIM(td_file%c_name) )
746
747               DO ji=1,td_file%i_nvar
748                  CALL logger_debug( " ADD VAR: in file : &
749                  &  variable "//TRIM(td_file%t_var(ji)%c_name)//&
750                  &  ", standard name "//TRIM(td_file%t_var(ji)%c_stdname) )
751               ENDDO
752
753            ELSE
754
755               CALL logger_debug( &
756               &  " FILE ADD VAR: add variable "//TRIM(td_var%c_name)//&
757               &  ", standard name "//TRIM(td_var%c_stdname)//&
758               &  ", in file "//TRIM(td_file%c_name) )
759
760               ! check used dimension
761               IF( file_check_var_dim(td_file, td_var) )THEN
762
763                  ! update dimension if need be
764                  DO ji=1,ip_maxdim
765                     IF( td_var%t_dim(ji)%l_use .AND. &
766                     &   .NOT. td_file%t_dim(ji)%l_use )THEN
767                        CALL file_add_dim(td_file,td_var%t_dim(ji))
768                     ENDIF
769                  ENDDO
770
771                  ! get index of new variable
772                  SELECT CASE(td_var%i_ndim)
773                     CASE(0)
774                        il_ind=td_file%i_n0d+1
775                        !il_rec=0
776                     CASE(1)
777                        il_ind=td_file%i_n0d+td_file%i_n1d+1
778                        !il_rec=1
779                     CASE(2)
780                        il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+1
781                        !il_rec=1
782                     CASE(3,4)
783                        il_ind=td_file%i_n0d+td_file%i_n1d+td_file%i_n2d+td_file%i_n3d+1
784                        !il_rec=td_file%t_dim(3)%i_len
785                  END SELECT
786
787                  IF( td_file%i_nvar > 0 )THEN
788                  ! already other variable in file structure
789                     ALLOCATE( tl_var(td_file%i_nvar), stat=il_status )
790                     IF(il_status /= 0 )THEN
791
792                        CALL logger_error( &
793                        &  " FILE ADD VAR: not enough space to put variables "//&
794                        &  "from "//TRIM(td_file%c_name)//&
795                        &  " in variable structure")
796
797                     ELSE
798
799                        ! save temporary variable of file structure
800                        tl_var(:)=var_copy(td_file%t_var(:))
801
802                        CALL var_clean( td_file%t_var(:) )
803                        DEALLOCATE(td_file%t_var)
804                        ALLOCATE( td_file%t_var(td_file%i_nvar+1), &
805                        &         stat=il_status)
806                        IF(il_status /= 0 )THEN
807
808                           CALL logger_error( &
809                           &  " FILE ADD VAR: not enough space to put variable "//&
810                           &  "in file structure "//TRIM(td_file%c_name) )
811
812                        ENDIF
813
814                        ! copy variable in file before
815                        ! variable with less than or equal dimension that new variable
816                        IF( il_ind > 1 )THEN
817                           td_file%t_var( 1:il_ind-1 ) = var_copy(tl_var(1:il_ind-1))
818                        ENDIF
819
820                        IF( il_ind < td_file%i_nvar+1 )THEN
821                           ! variable with more dimension than new variable
822                           td_file%t_var( il_ind+1 : td_file%i_nvar+1 ) = &
823                           &        var_copy( tl_var(il_ind : td_file%i_nvar) )
824                        ENDIF
825
826                        ! clean
827                        CALL var_clean(tl_var(:))
828                        DEALLOCATE(tl_var)
829                     ENDIF
830
831                  ELSE
832                  ! no variable in file structure
833                     IF( ASSOCIATED(td_file%t_var) )THEN
834                        CALL var_clean(td_file%t_var(:))
835                        DEALLOCATE(td_file%t_var)
836                     ENDIF
837                     ALLOCATE( td_file%t_var(td_file%i_nvar+1), stat=il_status )
838                     IF(il_status /= 0 )THEN
839
840                        CALL logger_error( &
841                        &  " FILE ADD VAR: not enough space to put variable "//&
842                        &  "in file structure "//TRIM(td_file%c_name) )
843
844                     ENDIF
845
846                  ENDIF
847
848                  ! add new variable in array of variable
849                  ALLOCATE( tl_var(1), stat=il_status )
850                  IF(il_status /= 0 )THEN
851
852                     CALL logger_error( &
853                     &  " FILE ADD VAR: not enough space to put variables from "//&
854                     &  TRIM(td_var%c_name)//" in variable structure")
855
856                  ELSE
857                     tl_var(1)=var_copy(td_var)
858
859                     ! update dimension name in new variable
860                     tl_var(1)%t_dim(:)%c_name = td_file%t_dim(:)%c_name
861                 
862                     ! add new variable
863                     td_file%t_var(il_ind)=var_copy(tl_var(1))
864
865                     ! update number of variable
866                     td_file%i_nvar=td_file%i_nvar+1
867                     SELECT CASE(tl_var(1)%i_ndim)
868                        CASE(0)
869                           td_file%i_n0d=td_file%i_n0d+1
870                        CASE(1)
871                           td_file%i_n1d=td_file%i_n1d+1
872                        CASE(2)
873                           td_file%i_n2d=td_file%i_n2d+1
874                        CASE(3,4)
875                           td_file%i_n3d=td_file%i_n3d+1
876                     END SELECT
877
878                     ! update variable id
879                     td_file%t_var(il_ind)%i_id=var_get_unit(td_file%t_var(:))
880
881                     ! update dimension used
882                     td_file%t_dim(:)%l_use=.FALSE.
883                     DO ji=1,ip_maxdim
884                        IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN
885                           td_file%t_dim(ji)%l_use=.TRUE.
886                        ENDIF
887                     ENDDO
888
889                     ! update number of dimension
890                     td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
891
892                     ! clean
893                     CALL var_clean( tl_var(:) )
894                     DEALLOCATE(tl_var)
895                  ENDIF
896               ENDIF
897            ENDIF
898         ENDIF
899      ENDIF
900
901   END SUBROUTINE file_add_var
902   !-------------------------------------------------------------------
903   !> @brief This subroutine delete a variable structure
904   !> in file structure, given variable name or standard name.
905   !
906   !> @author J.Paul
907   !> @date November, 2013 - Initial Version
908   !> @date February, 2015
909   !> - define local variable structure to avoid mistake with pointer
910   !
911   !> @param[inout] td_file   file structure
912   !> @param[in] cd_name      variable name or standard name
913   !-------------------------------------------------------------------
914   SUBROUTINE file__del_var_name(td_file, cd_name )
915      IMPLICIT NONE
916
917      ! Argument     
918      TYPE(TFILE)     , INTENT(INOUT) :: td_file
919      CHARACTER(LEN=*), INTENT(IN   ) :: cd_name
920
921      ! local variable
922      INTEGER(i4)       :: il_ind
923      TYPE(TVAR)        :: tl_var
924      !----------------------------------------------------------------
925
926      ! check if file opened
927      IF( TRIM(td_file%c_name) == '' )THEN
928
929         CALL logger_error( " FILE DEL VAR NAME: file structure unknown ")
930         CALL logger_debug( " FILE DEL VAR NAME: you should have used file_init before "//&
931         & "running file_del_var" )
932
933      ELSE
934
935         IF( td_file%i_nvar /= 0 )THEN
936
937            ! get the variable index, in file variable structure
938            il_ind=0
939            IF( ASSOCIATED(td_file%t_var) )THEN
940               il_ind=var_get_index(td_file%t_var(:), cd_name )
941            ENDIF
942
943            IF( il_ind /= 0 )THEN
944   
945               tl_var=var_copy(td_file%t_var(il_ind))
946               CALL file_del_var(td_file, tl_var)
947
948            ELSE
949
950               CALL logger_debug( &
951               &  " FILE DEL VAR NAME: there is no variable with name or "//&
952               &  "standard name "//TRIM(cd_name)//" in file "//&
953               &  TRIM(td_file%c_name))
954
955            ENDIF
956
957         ELSE
958            CALL logger_debug( " FILE DEL VAR NAME: "//&
959            &        "no variable associated to file "//&
960            &        TRIM(td_file%c_name) )
961         ENDIF
962
963      ENDIF
964
965   END SUBROUTINE file__del_var_name
966   !-------------------------------------------------------------------
967   !> @brief This subroutine delete a variable structure
968   !> in file structure, given variable structure.
969   !>
970   !> @author J.Paul
971   !> @date November, 2013 - Initial Version
972   !>
973   !> @param[inout] td_file   file structure
974   !> @param[in] td_var       variable structure
975   !-------------------------------------------------------------------
976   SUBROUTINE file__del_var_str(td_file, td_var)
977      IMPLICIT NONE
978
979      ! Argument     
980      TYPE(TFILE), INTENT(INOUT) :: td_file
981      TYPE(TVAR),  INTENT(IN)    :: td_var
982
983      ! local variable
984      INTEGER(i4) :: il_status
985      INTEGER(i4) :: il_ind
986      INTEGER(i4) :: il_rec
987      TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var
988
989      ! loop indices
990      INTEGER(i4) :: ji
991      !----------------------------------------------------------------
992
993      ! check if file opened
994      IF( TRIM(td_file%c_name) == '' )THEN
995
996         CALL logger_error( " FILE DEL VAR: file structure unknown ")
997         CALL logger_debug( " FILE DEL VAR: you should have used "//&
998         &  "file_init before running file_del_var" )     
999
1000      ELSE
1001
1002         ! check if variable is member of a file
1003         IF( td_var%l_file )THEN
1004            CALL logger_warn( &
1005            &  " FILE DEL VAR: variable "//TRIM(td_var%c_name)//&
1006            &  ", belong to file "//TRIM(td_file%c_name)//&
1007            &  " and can not be removed.")
1008         ELSE
1009            ! check if variable already in file structure
1010            il_ind=0
1011            IF( ASSOCIATED(td_file%t_var) )THEN
1012               il_ind=var_get_index( td_file%t_var(:), td_var%c_name, &
1013               &                                       td_var%c_stdname )
1014            ENDIF
1015
1016            IF( il_ind == 0 )THEN
1017
1018               CALL logger_warn( "FILE DEL VAR: no variable "//&
1019               &     TRIM(td_var%c_name)//", in file "//TRIM(td_file%c_name) )
1020
1021               DO ji=1,td_file%i_nvar
1022                  CALL logger_debug( "FILE DEL VAR: in file "//&
1023                  &  TRIM(td_file%t_var(ji)%c_name)//", standard name "//&
1024                  &  TRIM(td_file%t_var(ji)%c_stdname) )
1025               ENDDO
1026
1027            ELSE
1028               
1029               CALL logger_trace( "FILE DEL VAR: delete variable "//&
1030               &  TRIM(td_var%c_name)//", from file "//TRIM(td_file%c_name) )
1031
1032               ALLOCATE( tl_var(td_file%i_nvar-1), stat=il_status )
1033               IF(il_status /= 0 )THEN
1034
1035                  CALL logger_error( &
1036                  &  " FILE DEL VAR: not enough space to put variables from "//&
1037                  &  TRIM(td_file%c_name)//" in temporary variable structure")
1038
1039               ELSE
1040
1041                  ! save temporary variable's file structure
1042                  IF( il_ind > 1 )THEN
1043                     tl_var(1:il_ind-1)=var_copy(td_file%t_var(1:il_ind-1))
1044                  ENDIF
1045
1046                  IF( il_ind < td_file%i_nvar )THEN
1047                     tl_var(il_ind:)=var_copy(td_file%t_var(il_ind+1:))
1048                  ENDIF
1049
1050                  ! new number of variable in file
1051                  td_file%i_nvar=td_file%i_nvar-1
1052
1053                  SELECT CASE(td_var%i_ndim)
1054                     CASE(0)
1055                        td_file%i_n0d=td_file%i_n0d-1
1056                        il_rec=0
1057                     CASE(1)
1058                        td_file%i_n1d=td_file%i_n1d-1
1059                        il_rec=1
1060                     CASE(2)
1061                        td_file%i_n2d=td_file%i_n2d-1
1062                        il_rec=1
1063                     CASE(3,4)
1064                        td_file%i_n3d=td_file%i_n3d-1
1065                        il_rec=td_file%t_dim(3)%i_len
1066                  END SELECT
1067
1068                  CALL var_clean( td_file%t_var(:) )
1069                  DEALLOCATE(td_file%t_var)
1070
1071                  IF( td_file%i_nvar > 0 )THEN
1072                     ALLOCATE( td_file%t_var(td_file%i_nvar), stat=il_status )
1073                     IF(il_status /= 0 )THEN
1074
1075                        CALL logger_error( " FILE DEL VAR: not enough space"//&
1076                        &  "to put variables in file structure "//&
1077                        &  TRIM(td_file%c_name) )
1078
1079                     ENDIF
1080
1081                     ! copy attribute in file before
1082                     td_file%t_var(:)=var_copy(tl_var(:))
1083
1084                     ! update dimension used
1085                     td_file%t_dim(:)%l_use=.FALSE.
1086                     DO ji=1,ip_maxdim
1087                        IF( ANY(td_file%t_var(:)%t_dim(ji)%l_use) )THEN
1088                           td_file%t_dim(ji)%l_use=.TRUE.
1089                        ENDIF
1090                     ENDDO
1091
1092                     ! update number of dimension
1093                     td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
1094
1095                  ENDIF
1096
1097                  ! clean
1098                  CALL var_clean(tl_var(:))
1099                  DEALLOCATE(tl_var)
1100                 
1101               ENDIF
1102            ENDIF
1103         ENDIF
1104      ENDIF
1105
1106   END SUBROUTINE file__del_var_str
1107   !-------------------------------------------------------------------
1108   !> @brief This subroutine overwrite variable structure
1109   !> in file structure.
1110   !
1111   !> @warning change variable id in file structure.
1112   !
1113   !> @author J.Paul
1114   !> @date November, 2013 - Initial Version
1115   !
1116   !> @param[inout] td_file   file structure
1117   !> @param[in] td_var       variable structure
1118   !-------------------------------------------------------------------
1119   SUBROUTINE file_move_var(td_file, td_var)
1120      IMPLICIT NONE
1121
1122      ! Argument     
1123      TYPE(TFILE), INTENT(INOUT) :: td_file
1124      TYPE(TVAR),  INTENT(IN)    :: td_var
1125
1126      ! local variable
1127      TYPE(TVAR) :: tl_var
1128      !----------------------------------------------------------------
1129
1130      ! copy variable
1131      tl_var=var_copy(td_var)
1132
1133      ! remove variable with same name or standard name
1134      CALL file_del_var(td_file, tl_var)
1135
1136      ! add new variable
1137      CALL file_add_var(td_file, tl_var)
1138
1139      ! clean
1140      CALL var_clean(tl_var)
1141
1142   END SUBROUTINE file_move_var
1143   !-------------------------------------------------------------------
1144   !> @brief This subroutine add a global attribute
1145   !> in a file structure.<br/>
1146   !> Do not overwrite, if attribute already in file structure.
1147   !
1148   !> @author J.Paul
1149   !> @date November, 2013 - Initial Version
1150   !
1151   !> @param[inout] td_file   file structure
1152   !> @param[in] td_att       attribute structure
1153   !-------------------------------------------------------------------
1154   SUBROUTINE file_add_att(td_file, td_att)
1155      IMPLICIT NONE
1156
1157      ! Argument     
1158      TYPE(TFILE), INTENT(INOUT) :: td_file
1159      TYPE(TATT),  INTENT(IN)    :: td_att
1160
1161      ! local variable
1162      INTEGER(i4) :: il_status
1163      INTEGER(i4) :: il_ind
1164      TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
1165
1166      ! loop indices
1167      INTEGER(i4) :: ji
1168      !----------------------------------------------------------------
1169
1170      ! check if file opened
1171      IF( TRIM(td_file%c_name) == '' )THEN
1172
1173         CALL logger_error( " FILE ADD ATT: file structure unknown ")
1174         CALL logger_debug( " FILE ADD ATT: you should have used file_init before "//&
1175         & "running file_add_att" )     
1176
1177      ELSE
1178
1179         ! check if attribute already in file structure
1180         il_ind=0
1181         IF( ASSOCIATED(td_file%t_att) )THEN
1182            il_ind=att_get_index( td_file%t_att(:), td_att%c_name )
1183         ENDIF
1184
1185         IF( il_ind /= 0 )THEN
1186         
1187            CALL logger_error( &
1188            &  " FILE ADD ATT: attribute "//TRIM(td_att%c_name)//&
1189            &  ", already in file "//TRIM(td_file%c_name) )
1190
1191            DO ji=1,td_file%i_natt
1192               CALL logger_debug( &
1193               &  " FILE ADD ATT: in file "//TRIM(td_file%t_att(ji)%c_name) )
1194            ENDDO
1195
1196         ELSE
1197           
1198            CALL logger_trace( &
1199            &  " FILE ADD ATT: add attribute "//TRIM(td_att%c_name)//&
1200            &  ", in file "//TRIM(td_file%c_name) )
1201
1202            IF( td_file%i_natt > 0 )THEN
1203            ! already other attribute in file structure
1204               ALLOCATE( tl_att(td_file%i_natt), stat=il_status )
1205               IF(il_status /= 0 )THEN
1206
1207                  CALL logger_error( &
1208                  &  " FILE ADD ATT: not enough space to put attributes from "//&
1209                  &  TRIM(td_file%c_name)//" in temporary attribute structure")
1210
1211               ELSE
1212
1213                  ! save temporary global attribute's file structure
1214                  tl_att(:)=att_copy(td_file%t_att(:))
1215
1216                  CALL att_clean( td_file%t_att(:) )
1217                  DEALLOCATE(td_file%t_att)
1218                  ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status )
1219                  IF(il_status /= 0 )THEN
1220
1221                     CALL logger_error( &
1222                     &  " FILE ADD ATT: not enough space to put attributes "//&
1223                     &  "in file structure "//TRIM(td_file%c_name) )
1224
1225                  ENDIF
1226
1227                  ! copy attribute in file before
1228                  td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:))
1229
1230                   ! clean
1231                  CALL att_clean(tl_att(:))
1232                  DEALLOCATE(tl_att)
1233
1234               ENDIF
1235            ELSE
1236            ! no attribute in file structure
1237               IF( ASSOCIATED(td_file%t_att) )THEN
1238                  CALL att_clean(td_file%t_att(:))
1239                  DEALLOCATE(td_file%t_att)
1240               ENDIF
1241
1242               ALLOCATE( td_file%t_att(td_file%i_natt+1), stat=il_status )
1243               IF(il_status /= 0 )THEN
1244
1245                  CALL logger_error( &
1246                  &  " FILE ADD ATT: not enough space to put attributes "//&
1247                  &  "in file structure "//TRIM(td_file%c_name) )
1248
1249               ENDIF
1250            ENDIF
1251            ! add new attribute
1252            td_file%t_att(td_file%i_natt+1)=att_copy(td_att)
1253
1254            ! update number of attribute
1255            td_file%i_natt=td_file%i_natt+1
1256         ENDIF
1257      ENDIF
1258
1259   END SUBROUTINE file_add_att
1260   !-------------------------------------------------------------------
1261   !> @brief This subroutine delete a global attribute structure
1262   !> in file structure, given attribute name.
1263   !
1264   !> @author J.Paul
1265   !> @date November, 2013 - Initial Version
1266   !> @date February, 2015
1267   !> - define local attribute structure to avoid mistake
1268   !> with pointer
1269   !
1270   !> @param[inout] td_file   file structure
1271   !> @param[in] cd_name      attribute name
1272   !-------------------------------------------------------------------
1273   SUBROUTINE file__del_att_name(td_file, cd_name )
1274      IMPLICIT NONE
1275
1276      ! Argument     
1277      TYPE(TFILE)     , INTENT(INOUT) :: td_file
1278      CHARACTER(LEN=*), INTENT(IN   ) :: cd_name
1279
1280      ! local variable
1281      INTEGER(i4)       :: il_ind
1282      TYPE(TATT)        :: tl_att
1283      !----------------------------------------------------------------
1284
1285      ! check if file opened
1286      IF( TRIM(td_file%c_name) == '' )THEN
1287
1288         CALL logger_error( " FILE DEL ATT NAME: file structure unknown ")
1289         CALL logger_debug( " FILE DEL ATT NAME: you should have "//&
1290         &  "used file_init before running file_del_att" )
1291
1292      ELSE
1293
1294         IF( td_file%i_natt /= 0 )THEN
1295
1296            ! get the variable id, in file variable structure
1297            il_ind=0
1298            IF( ASSOCIATED(td_file%t_att) )THEN
1299               il_ind=att_get_index(td_file%t_att(:), cd_name )
1300            ENDIF
1301
1302            IF( il_ind /= 0 )THEN
1303   
1304               tl_att=att_copy(td_file%t_att(il_ind))
1305               CALL file_del_att(td_file, tl_att)
1306
1307            ELSE
1308
1309               CALL logger_debug( &
1310               &  " FILE DEL ATT NAME: there is no attribute with name "//&
1311               &  TRIM(cd_name)//" in file "//TRIM(td_file%c_name))
1312
1313            ENDIF
1314
1315         ELSE
1316            CALL logger_debug( " FILE DEL ATT NAME: no attribute "//&
1317            &  "associated to file "//TRIM(td_file%c_name) )
1318         ENDIF
1319
1320      ENDIF
1321
1322   END SUBROUTINE file__del_att_name
1323   !-------------------------------------------------------------------
1324   !> @brief This subroutine delete a global attribute structure
1325   !> from file structure, given attribute structure.
1326   !
1327   !> @author J.Paul
1328   !> @date November, 2013 - Initial Version
1329   !
1330   !> @param[inout] td_file   file structure
1331   !> @param[in] td_att       attribute structure
1332   !-------------------------------------------------------------------
1333   SUBROUTINE file__del_att_str(td_file, td_att)
1334      IMPLICIT NONE
1335
1336      ! Argument     
1337      TYPE(TFILE), INTENT(INOUT) :: td_file
1338      TYPE(TATT),  INTENT(IN)    :: td_att
1339
1340      ! local variable
1341      INTEGER(i4) :: il_status
1342      INTEGER(i4) :: il_ind
1343      TYPE(TATT), DIMENSION(:), ALLOCATABLE :: tl_att
1344
1345      ! loop indices
1346      !----------------------------------------------------------------
1347
1348      ! check if file opened
1349      IF( TRIM(td_file%c_name) == '' )THEN
1350
1351         CALL logger_error( " FILE DEL ATT: file structure unknown ")
1352         CALL logger_debug( " FILE DEL ATT: you should have used "//&
1353         &  "file_init before running file_del_att" )     
1354
1355      ELSE
1356
1357         ! check if attribute already in file structure
1358         il_ind=0
1359         IF( ASSOCIATED(td_file%t_att) )THEN
1360            il_ind=att_get_index( td_file%t_att(:), td_att%c_name )
1361         ENDIF
1362
1363         IF( il_ind == 0 )THEN
1364
1365            CALL logger_error( &
1366            &  " FILE DEL ATT: no attribute "//TRIM(td_att%c_name)//&
1367            &  ", in file "//TRIM(td_file%c_name) )
1368
1369         ELSE
1370           
1371            CALL logger_trace( &
1372            &  " FILE DEL ATT: del attribute "//TRIM(td_att%c_name)//&
1373            &  ", in file "//TRIM(td_file%c_name) )
1374
1375            ALLOCATE( tl_att(td_file%i_natt-1), stat=il_status )
1376            IF(il_status /= 0 )THEN
1377
1378               CALL logger_error( &
1379               &  " FILE ADD ATT: not enough space to put attributes from "//&
1380               &  TRIM(td_file%c_name)//" in temporary attribute structure")
1381
1382            ELSE
1383
1384               ! save temporary global attribute's file structure
1385               IF( il_ind > 1 )THEN
1386                  tl_att(1:il_ind-1)=att_copy(td_file%t_att(1:il_ind-1))
1387               ENDIF
1388
1389               IF( il_ind < td_file%i_natt )THEN
1390                  tl_att(il_ind:)=att_copy(td_file%t_att(il_ind+1:))
1391               ENDIF
1392
1393               CALL att_clean( td_file%t_att(:) )
1394               DEALLOCATE(td_file%t_att)
1395
1396               ! new number of attribute in file
1397               td_file%i_natt=td_file%i_natt-1
1398
1399               ALLOCATE( td_file%t_att(td_file%i_natt), stat=il_status )
1400               IF(il_status /= 0 )THEN
1401
1402                  CALL logger_error( &
1403                  &  " FILE ADD ATT: not enough space to put attributes "//&
1404                  &  "in file structure "//TRIM(td_file%c_name) )
1405
1406               ENDIF
1407
1408               ! copy attribute in file before
1409               td_file%t_att(1:td_file%i_natt)=att_copy(tl_att(:))
1410
1411               ! clean
1412               CALL att_clean(tl_att(:))
1413               DEALLOCATE(tl_att)
1414
1415            ENDIF
1416         ENDIF
1417      ENDIF
1418
1419   END SUBROUTINE file__del_att_str
1420   !-------------------------------------------------------------------
1421   !> @brief This subroutine move a global attribute structure
1422   !> from file structure.
1423   !> @warning change attribute id in file structure.
1424   !
1425   !> @author J.Paul
1426   !> @date November, 2013 - Initial Version
1427   !
1428   !> @param[inout] td_file   file structure
1429   !> @param[in] td_att       attribute structure
1430   !-------------------------------------------------------------------
1431   SUBROUTINE file_move_att(td_file, td_att)
1432      IMPLICIT NONE
1433
1434      ! Argument     
1435      TYPE(TFILE), INTENT(INOUT) :: td_file
1436      TYPE(TATT),  INTENT(IN)    :: td_att
1437
1438      ! local variable
1439      TYPE(TATT)  :: tl_att
1440      INTEGER(i4) :: il_ind
1441      !----------------------------------------------------------------
1442
1443      ! copy attribute
1444      tl_att=att_copy(td_att)
1445
1446      IF( ASSOCIATED(td_file%t_att) )THEN
1447         il_ind=att_get_index(td_file%t_att(:),TRIM(tl_att%c_name))
1448         IF( il_ind /= 0 )THEN
1449            ! remove attribute with same name
1450            CALL file_del_att(td_file, tl_att)
1451         ENDIF
1452      ENDIF
1453
1454      ! add new attribute
1455      CALL file_add_att(td_file, tl_att)
1456
1457       ! clean
1458       CALL att_clean(tl_att)
1459
1460   END SUBROUTINE file_move_att
1461   !-------------------------------------------------------------------
1462   !> @brief This subroutine add a dimension structure in file
1463   !> structure.
1464   !> Do not overwrite, if dimension already in file structure.
1465   !
1466   !> @author J.Paul
1467   !> @date November, 2013 - Initial Version
1468   !> @date September, 2014
1469   !> - do not reorder dimension, before put in file
1470   !
1471   !> @param[inout] td_file   file structure
1472   !> @param[in] td_dim       dimension structure
1473   !-------------------------------------------------------------------
1474   SUBROUTINE file_add_dim(td_file, td_dim)
1475      IMPLICIT NONE
1476
1477      ! Argument     
1478      TYPE(TFILE)     , INTENT(INOUT) :: td_file
1479      TYPE(TDIM)      , INTENT(IN   ) :: td_dim
1480
1481      ! local variable
1482      INTEGER(i4) :: il_ind
1483
1484      ! loop indices
1485      INTEGER(i4) :: ji
1486      !----------------------------------------------------------------
1487      ! check if file opened
1488      IF( TRIM(td_file%c_name) == '' )THEN
1489
1490         CALL logger_error( " FILE ADD DIM: file structure unknown ")
1491         CALL logger_debug( " FILE ADD DIM: you should have used "//&
1492         &  "file_init before running file_add_dim" )     
1493
1494      ELSE
1495
1496         IF( td_file%i_ndim <= ip_maxdim )THEN
1497
1498            ! check if dimension already in file structure
1499            il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname)
1500            IF( il_ind /= 0 )THEN
1501               IF( td_file%t_dim(il_ind)%l_use )THEN
1502                  CALL logger_error( &
1503                  &  "FILE ADD DIM: dimension "//TRIM(td_dim%c_name)//&
1504                  &  ", short name "//TRIM(td_dim%c_sname)//&
1505                  &  ", already used in file "//TRIM(td_file%c_name) )
1506               ELSE
1507                  ! replace dimension
1508                  td_file%t_dim(il_ind)=dim_copy(td_dim)
1509                  td_file%t_dim(il_ind)%i_id=il_ind
1510                  td_file%t_dim(il_ind)%l_use=.TRUE.
1511               ENDIF
1512            ELSE
1513               IF( td_file%i_ndim == ip_maxdim )THEN
1514                  CALL logger_error( &
1515                  &  "FILE ADD DIM: can not add dimension "//TRIM(td_dim%c_name)//&
1516                  &  ", short name "//TRIM(td_dim%c_sname)//&
1517                  &  ", in file "//TRIM(td_file%c_name)//". Already "//&
1518                  &  TRIM(fct_str(ip_maxdim))//" dimensions." )
1519               ELSE
1520                  ! search empty dimension
1521                  DO ji=1,ip_maxdim
1522                     IF( td_file%t_dim(ji)%i_id == 0 )THEN
1523                        il_ind=ji 
1524                        EXIT
1525                     ENDIF
1526                  ENDDO
1527 
1528                  ! add new dimension   
1529                  td_file%t_dim(il_ind)=dim_copy(td_dim)
1530                  ! update number of attribute
1531                  td_file%i_ndim=COUNT(td_file%t_dim(:)%l_use)
1532
1533                  td_file%t_dim(il_ind)%i_id=td_file%i_ndim
1534                  td_file%t_dim(il_ind)%l_use=.TRUE.
1535               ENDIF               
1536            ENDIF
1537
1538         ELSE
1539            CALL logger_error( &
1540            &  " FILE ADD DIM: too much dimension in file "//&
1541            &  TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
1542         ENDIF
1543
1544      ENDIF
1545
1546   END SUBROUTINE file_add_dim
1547   !-------------------------------------------------------------------
1548   !> @brief This subroutine delete a dimension structure in file
1549   !> structure.
1550   !>
1551   !> @author J.Paul
1552   !> @date November, 2013 - Initial Version
1553   !
1554   !> @param[inout] td_file   file structure
1555   !> @param[in] td_dim       dimension structure
1556   !-------------------------------------------------------------------
1557   SUBROUTINE file_del_dim(td_file, td_dim)
1558      IMPLICIT NONE
1559
1560      ! Argument     
1561      TYPE(TFILE)     , INTENT(INOUT) :: td_file
1562      TYPE(TDIM)      , INTENT(IN   ) :: td_dim
1563
1564      ! local variable
1565      INTEGER(i4) :: il_status
1566      INTEGER(i4) :: il_ind
1567
1568      TYPE(TDIM), DIMENSION(:), ALLOCATABLE  :: tl_dim
1569
1570      ! loop indices
1571      INTEGER(i4) :: ji
1572      !----------------------------------------------------------------
1573      ! check if file opened
1574      IF( TRIM(td_file%c_name) == '' )THEN
1575
1576         CALL logger_error( " FILE DEL DIM: file structure unknown ")
1577         CALL logger_debug( " FILE DEL DIM: you should have used "//&
1578         &  "file_init before running file_del_dim" )     
1579
1580      ELSE
1581
1582         ! check if dimension already in file structure
1583         il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_sname)
1584         IF( il_ind == 0 )THEN
1585
1586            CALL logger_error( &
1587            &  "FILE DEL DIM: no dimension "//TRIM(td_dim%c_name)//&
1588            &  ", short name "//TRIM(td_dim%c_sname)//&
1589            &  ", in file "//TRIM(td_file%c_name) )
1590
1591         ELSE
1592            ALLOCATE( tl_dim(td_file%i_ndim-1), stat=il_status )
1593            IF(il_status /= 0 )THEN
1594
1595               CALL logger_error( &
1596               &  "FILE DEL DIM: not enough space to put dimensions from "//&
1597               &  TRIM(td_file%c_name)//" in temporary dimension structure")
1598
1599            ELSE           
1600               ! save temporary dimension's mpp structure
1601               tl_dim( 1 : il_ind-1 ) = dim_copy(td_file%t_dim(1 : il_ind-1))
1602               tl_dim( il_ind : td_file%i_ndim-1 ) = &
1603               &      dim_copy(td_file%t_dim(il_ind+1 : td_file%i_ndim))
1604
1605               ! remove dimension from file
1606               CALL dim_clean(td_file%t_dim(:))
1607               ! copy dimension in file, except one
1608               td_file%t_dim(1:td_file%i_ndim)=dim_copy(tl_dim(:))
1609
1610               ! update number of dimension
1611               td_file%i_ndim=td_file%i_ndim-1
1612
1613               ! update dimension id
1614               DO ji=1,td_file%i_ndim
1615                  td_file%t_dim(ji)%i_id=ji
1616               ENDDO
1617
1618               ! clean
1619               CALL dim_clean(tl_dim(:))
1620               DEALLOCATE(tl_dim)
1621            ENDIF
1622         ENDIF
1623      ENDIF
1624
1625   END SUBROUTINE file_del_dim
1626   !-------------------------------------------------------------------
1627   !> @brief This subroutine move a dimension structure
1628   !> in file structure.
1629   !> @warning change dimension order in file structure.
1630   !
1631   !> @author J.Paul
1632   !> @date November, 2013 - Initial Version
1633   !
1634   !> @param[inout] td_file   file structure
1635   !> @param[in] td_dim       dimension structure
1636   !-------------------------------------------------------------------
1637   SUBROUTINE file_move_dim(td_file, td_dim)
1638      IMPLICIT NONE
1639
1640      ! Argument     
1641      TYPE(TFILE)     , INTENT(INOUT) :: td_file
1642      TYPE(TDIM)      , INTENT(IN   ) :: td_dim
1643
1644      ! local variable
1645      INTEGER(i4) :: il_ind
1646      INTEGER(i4) :: il_dimid
1647      !----------------------------------------------------------------
1648      IF( td_file%i_ndim <= ip_maxdim )THEN
1649
1650         ! check if dimension already in mpp structure
1651         il_ind=dim_get_index(td_file%t_dim(:), td_dim%c_name, td_dim%c_sname)
1652         IF( il_ind /= 0 )THEN
1653
1654            il_dimid=td_file%t_dim(il_ind)%i_id
1655            ! replace dimension
1656            td_file%t_dim(il_ind)=dim_copy(td_dim)
1657            td_file%t_dim(il_ind)%i_id=il_dimid
1658            td_file%t_dim(il_ind)%l_use=.TRUE.
1659
1660         ELSE
1661            CALL file_add_dim(td_file, td_dim)
1662         ENDIF
1663
1664      ELSE
1665         CALL logger_error( &
1666         &  "FILE MOVE DIM: too much dimension in mpp "//&
1667         &  TRIM(td_file%c_name)//" ("//TRIM(fct_str(td_file%i_ndim))//")")
1668      ENDIF
1669
1670   END SUBROUTINE file_move_dim
1671   !-------------------------------------------------------------------
1672   !> @brief This subroutine print some information about file strucutre.
1673   !
1674   !> @author J.Paul
1675   !> @date November, 2013 - Initial Version
1676   !
1677   !> @param[in] td_file   file structure
1678   !-------------------------------------------------------------------
1679   SUBROUTINE file_print(td_file)
1680      IMPLICIT NONE
1681
1682      ! Argument     
1683      TYPE(TFILE), INTENT(IN) :: td_file
1684
1685      ! local variable
1686      CHARACTER(LEN=lc) :: cl_mode
1687
1688      ! loop indices
1689      INTEGER(i4) :: ji
1690      !----------------------------------------------------------------
1691
1692      cl_mode='READ'
1693      IF( td_file%l_wrt ) cl_mode='WRITE'
1694
1695      WRITE(*,'((a,a),2(/3x,a,a),4(/3x,a,i0))')&
1696      &  "File : ",TRIM(td_file%c_name), &
1697      &  " type : ",TRIM(td_file%c_type), &
1698      &  " mode : ",TRIM(cl_mode), &
1699      &  " id   : ",td_file%i_id, &
1700      &  " ndim : ",td_file%i_ndim, &
1701      &  " natt : ",td_file%i_natt, &
1702      &  " nvar : ",td_file%i_nvar
1703
1704      SELECT CASE(TRIM(td_file%c_type))
1705         CASE('cdf')
1706            WRITE(*,'((/3x,a,a),(/3x,a,i3))')&
1707            &  "define mode : ",TRIM(fct_str(td_file%l_def)),&
1708            &  "unlimited id : ",td_file%i_uldid
1709         CASE('dimg')
1710            WRITE(*,'(5(/3x,a,i0))')&
1711            &  " record length : ",td_file%i_recl, &
1712            &  " n0d : ",td_file%i_n0d, &
1713            &  " n1d : ",td_file%i_n1d, &
1714            &  " n2d : ",td_file%i_n2d, &
1715            &  " n3d : ",td_file%i_n3d
1716      END SELECT
1717
1718      ! print dimension
1719      IF(  td_file%i_ndim /= 0 )THEN
1720         WRITE(*,'(/a)') " File dimension"
1721         DO ji=1,ip_maxdim
1722            IF( td_file%t_dim(ji)%l_use )THEN
1723               CALL dim_print(td_file%t_dim(ji))
1724            ENDIF
1725         ENDDO
1726      ENDIF
1727
1728      ! print global attribute
1729      IF( td_file%i_natt /= 0 )THEN
1730         WRITE(*,'(/a)') " File attribute"
1731         DO ji=1,td_file%i_natt
1732            CALL att_print(td_file%t_att(ji))
1733         ENDDO
1734      ENDIF
1735
1736      ! print variable
1737      IF( td_file%i_nvar /= 0 )THEN
1738         WRITE(*,'(/a)') " File variable"
1739         DO ji=1,td_file%i_nvar
1740            CALL var_print(td_file%t_var(ji),.FALSE.)
1741         ENDDO
1742      ENDIF
1743
1744   END SUBROUTINE file_print
1745   !-------------------------------------------------------------------
1746   !> @brief This function get suffix of file name.
1747   !> @details
1748   !> we assume suffix is define as alphanumeric character following the
1749   !> last '.' in file name.<br/>
1750   !> If no suffix is found, return empty character.
1751   !
1752   !> @author J.Paul
1753   !> @date November, 2013 - Initial Version
1754   !
1755   !> @param[in] cd_file   file structure
1756   !> @return suffix
1757   !-------------------------------------------------------------------
1758   CHARACTER(LEN=lc) FUNCTION file__get_suffix(cd_file)
1759      IMPLICIT NONE
1760
1761      ! Argument     
1762      CHARACTER(LEN=*), INTENT(IN) :: cd_file
1763
1764      ! local variable
1765      INTEGER(i4) :: il_ind
1766      !----------------------------------------------------------------
1767
1768      CALL logger_trace( "FILE GET SUFFIX: look for suffix in file name "//&
1769      &               TRIM(cd_file) )
1770
1771      il_ind=INDEX(TRIM(cd_file),'.',BACK=.TRUE.)
1772      IF( il_ind /= 0 )THEN
1773         ! read number in basename
1774         READ( cd_file(il_ind:),'(a)' ) file__get_suffix
1775
1776         IF( fct_is_num(file__get_suffix(2:)) )THEN
1777            file__get_suffix=''
1778         ENDIF
1779
1780      ELSE
1781         file__get_suffix=''
1782      ENDIF
1783
1784   END FUNCTION file__get_suffix
1785   !-------------------------------------------------------------------
1786   !> @brief This function get number in file name without suffix.
1787   !> @details
1788   !> Actually it get the number following the last separator.
1789   !> separator could be '.' or '_'.
1790   !
1791   !> @author J.Paul
1792   !> @date November, 2013 - Initial Version
1793   !> @date February, 2015
1794   !> - add case to not return date (yyyymmdd) at the end of filename
1795   !> @date February, 2015
1796   !> - add case to not return release number
1797   !> we assume release number only on one digit (ex : file_v3.5.nc)
1798   !
1799   !> @param[in] cd_file   file name (without suffix)
1800   !> @return character file number.
1801   !-------------------------------------------------------------------
1802   CHARACTER(LEN=lc) FUNCTION file__get_number(cd_file)
1803      IMPLICIT NONE
1804
1805      ! Argument     
1806      CHARACTER(LEN=lc), INTENT(IN) :: cd_file
1807
1808      ! local variable
1809      INTEGER(i4) :: il_indmax
1810      INTEGER(i4) :: il_ind
1811
1812      ! loop indices
1813      INTEGER(i4) :: ji
1814      !----------------------------------------------------------------
1815
1816      ! get number position in file name
1817      il_indmax=0
1818      DO ji=1,ip_nsep
1819         il_ind=INDEX(TRIM(cd_file),TRIM(cp_sep(ji)),BACK=.TRUE.)
1820         IF( il_ind > il_indmax )THEN
1821            il_indmax=il_ind
1822         ENDIF
1823      ENDDO
1824
1825      IF( il_indmax /= 0 )THEN
1826         ! read number in basename
1827         READ( cd_file(il_indmax:),'(a)' ) file__get_number
1828
1829         IF( .NOT. fct_is_num(file__get_number(2:)) )THEN
1830            file__get_number=''
1831         ELSEIF( LEN(TRIM(file__get_number))-1 == 8 )THEN
1832            ! date case yyyymmdd
1833            file__get_number=''
1834         ELSEIF( LEN(TRIM(file__get_number))-1 == 1 )THEN
1835            ! release number case
1836            file__get_number=''
1837         ENDIF
1838      ELSE
1839         file__get_number=''
1840      ENDIF
1841
1842   END FUNCTION file__get_number
1843   !-------------------------------------------------------------------
1844   !> @brief This function rename file name, given processor number.
1845   !> @details
1846   !> If no processor number is given, return file name without number
1847   !> If processor number is given, return file name with new number
1848   !
1849   !> @author J.Paul
1850   !> @date November, 2013 - Initial Version
1851   !
1852   !> @param[in] td_file   file structure
1853   !> @param[in] id_num    processor number (start to 1)
1854   !> @return file name
1855   !-------------------------------------------------------------------
1856   CHARACTER(LEN=lc) FUNCTION file__rename_char(cd_file, id_num)
1857      IMPLICIT NONE
1858
1859      ! Argument     
1860      CHARACTER(LEN=*), INTENT(IN) :: cd_file
1861      INTEGER(i4),      INTENT(IN), OPTIONAL :: id_num
1862
1863      ! local variable
1864      CHARACTER(LEN=lc) :: cl_suffix
1865      CHARACTER(LEN=lc) :: cl_file
1866      CHARACTER(LEN=lc) :: cl_number
1867      CHARACTER(LEN=lc) :: cl_base
1868      CHARACTER(LEN=lc) :: cl_sep
1869      CHARACTER(LEN=lc) :: cl_format
1870      INTEGER(i4)       :: il_ind
1871      INTEGER(i4)       :: il_numlen
1872      !----------------------------------------------------------------
1873
1874      ! get suffix
1875      cl_suffix=file__get_suffix(cd_file)
1876      IF( TRIM(cl_suffix) /= '' )THEN
1877         il_ind=INDEX(TRIM(cd_file),TRIM(cl_suffix(1:1)),BACK=.TRUE.)
1878         cl_file=TRIM(cd_file(:il_ind-1))
1879      ELSE
1880         cl_file=TRIM(cd_file)
1881      ENDIF
1882
1883      cl_number=file__get_number(cl_file)
1884      IF( TRIM(cl_number) /= '' )THEN
1885         il_ind=INDEX(TRIM(cl_file),TRIM(cl_number(1:1)),BACK=.TRUE.)
1886         cl_base=TRIM(cl_file(:il_ind-1))
1887
1888         cl_sep=TRIM(cl_number(1:1))
1889         il_numlen=LEN(TRIM(cl_number))-1
1890      ELSE
1891         cl_base=TRIM(cl_file)
1892         il_numlen=4
1893         cl_sep='_'
1894      ENDIF
1895
1896      IF( PRESENT(id_num) )THEN
1897         ! format
1898         WRITE(cl_format,'(a,i1.1,a,i1.1,a)') '(a,a,i',il_numlen,'.',il_numlen,',a)'
1899         WRITE(file__rename_char,cl_format) TRIM(cl_base),TRIM(cl_sep),id_num,TRIM(cl_suffix)
1900      ELSE
1901         WRITE(file__rename_char,'(a,a)') TRIM(cl_base),TRIM(cl_suffix)
1902      ENDIF
1903      CALL logger_trace(" FILE RENAME : "//TRIM(file__rename_char))
1904
1905   END FUNCTION file__rename_char
1906   !-------------------------------------------------------------------
1907   !> @brief This function rename file name, given file structure.
1908   !> @details
1909   !> If no processor number is given, return file name without number
1910   !> I processor number is given, return file name with new number
1911   !
1912   !> @author J.Paul
1913   !> @date November, 2013 - Initial Version
1914   !
1915   !> @param[in] td_file   file structure
1916   !> @param[in] id_num    processor number (start to 1)
1917   !> @return file structure
1918   !-------------------------------------------------------------------
1919   TYPE(TFILE) FUNCTION file__rename_str(td_file, id_num)
1920      IMPLICIT NONE
1921
1922      ! Argument     
1923      TYPE(TFILE), INTENT(IN) :: td_file
1924      INTEGER(i4), INTENT(IN), OPTIONAL :: id_num
1925
1926      ! local variable
1927      CHARACTER(LEN=lc) :: cl_name
1928      !----------------------------------------------------------------
1929
1930      ! change name
1931      cl_name=TRIM( file_rename(td_file%c_name, id_num) )
1932
1933      file__rename_str=file_init(TRIM(cl_name), TRIM(td_file%c_type))
1934
1935   END FUNCTION file__rename_str
1936   !-------------------------------------------------------------------
1937   !> @brief This function add suffix to file name.
1938   !
1939   !> @author J.Paul
1940   !> @date November, 2013 - Initial Version
1941   !
1942   !> @param[in] td_file   file structure
1943   !> @return file name
1944   !-------------------------------------------------------------------
1945   CHARACTER(LEN=lc) FUNCTION file_add_suffix(cd_file, cd_type)
1946      IMPLICIT NONE
1947
1948      ! Argument     
1949      CHARACTER(LEN=*), INTENT(IN) :: cd_file
1950      CHARACTER(LEN=*), INTENT(IN) :: cd_type
1951
1952      ! local variable
1953      INTEGER(i4)       :: il_ind
1954      CHARACTER(LEN=lc) :: cl_file
1955      CHARACTER(LEN=lc) :: cl_suffix
1956      !----------------------------------------------------------------
1957      ! get suffix
1958      cl_suffix=file__get_suffix(cd_file)
1959      IF( TRIM(cl_suffix) /= '' )THEN
1960         il_ind=INDEX(TRIM(cd_file),TRIM(cl_suffix(1:1)),BACK=.TRUE.)
1961         cl_file=TRIM(cd_file(:il_ind-1))
1962      ELSE
1963         cl_file=TRIM(cd_file)
1964      ENDIF
1965
1966      SELECT CASE(TRIM(cd_type))
1967         CASE('cdf')
1968            file_add_suffix=TRIM(cl_file)//'.nc'
1969         CASE('dimg')
1970            IF( TRIM(cl_suffix) /= '' )THEN
1971               file_add_suffix=TRIM(cl_file)//'.dimg'
1972            ELSE
1973               file_add_suffix=TRIM(cl_file)
1974            ENDIF
1975         CASE DEFAULT
1976            CALL logger_error(" FILE ADD SUFFIX: type unknown "//TRIM(cd_type))
1977      END SELECT
1978
1979   END FUNCTION file_add_suffix
1980   !-------------------------------------------------------------------
1981   !> @brief
1982   !>  This subroutine clean file strcuture.
1983   !
1984   !> @author J.Paul
1985   !> @date November, 2013 - Inital version
1986   !
1987   !> @param[inout] td_file   file strcuture
1988   !-------------------------------------------------------------------
1989   SUBROUTINE file__clean_unit( td_file )
1990      IMPLICIT NONE
1991      ! Argument
1992      TYPE(TFILE),  INTENT(INOUT) :: td_file
1993
1994      ! local variable
1995      TYPE(TFILE) :: tl_file ! empty file structure
1996
1997      ! loop indices
1998      !----------------------------------------------------------------
1999
2000      CALL logger_trace( &
2001      &  " FILE CLEAN: reset file "//TRIM(td_file%c_name) )
2002
2003      ! del attribute
2004      IF( ASSOCIATED( td_file%t_att ) )THEN
2005         CALL att_clean( td_file%t_att(:) )
2006         DEALLOCATE(td_file%t_att)
2007      ENDIF
2008
2009      ! del dimension
2010      IF( td_file%i_ndim /= 0 )THEN
2011         CALL dim_clean( td_file%t_dim(:) )
2012      ENDIF
2013
2014      ! del variable
2015      IF( ASSOCIATED( td_file%t_var ) )THEN
2016         CALL var_clean( td_file%t_var(:) )
2017         DEALLOCATE(td_file%t_var)
2018      ENDIF
2019
2020      ! replace by empty structure
2021      td_file=file_copy(tl_file)
2022
2023   END SUBROUTINE file__clean_unit
2024   !-------------------------------------------------------------------
2025   !> @brief
2026   !>  This subroutine clean file array of file strcuture.
2027   !
2028   !> @author J.Paul
2029   !> @date Marsh, 2014 - Inital version
2030   !
2031   !> @param[inout] td_file   array file strcuture
2032   !-------------------------------------------------------------------
2033   SUBROUTINE file__clean_arr( td_file )
2034      IMPLICIT NONE
2035      ! Argument
2036      TYPE(TFILE), DIMENSION(:), INTENT(INOUT) :: td_file
2037
2038      ! local variable
2039      ! loop indices
2040      INTEGER(i4) :: ji
2041      !----------------------------------------------------------------
2042
2043      DO ji=SIZE(td_file(:)),1,-1
2044         CALL file_clean(td_file(ji))
2045      ENDDO
2046
2047   END SUBROUTINE file__clean_arr
2048   !-------------------------------------------------------------------
2049   !> @brief This function return the file id, in a array of file
2050   !> structure,  given file name.
2051   !
2052   !> @author J.Paul
2053   !> @date November, 2013 - Initial Version
2054   !
2055   !> @param[in] td_file   array of file structure
2056   !> @param[in] cd_name   file name
2057   !> @return file id in array of file structure (0 if not found)
2058   !-------------------------------------------------------------------
2059   INTEGER(i4) FUNCTION file_get_id(td_file, cd_name)
2060      IMPLICIT NONE
2061      ! Argument     
2062      TYPE(TFILE)     , DIMENSION(:), INTENT(IN) :: td_file
2063      CHARACTER(LEN=*),               INTENT(IN) :: cd_name
2064
2065      ! local variable
2066      INTEGER(i4) :: il_size
2067
2068      ! loop indices
2069      INTEGER(i4) :: ji
2070      !----------------------------------------------------------------
2071      file_get_id=0
2072      il_size=SIZE(td_file(:))
2073
2074      ! check if file is in array of file structure
2075      DO ji=1,il_size
2076         ! look for file name
2077         IF( fct_lower(td_file(ji)%c_name) == fct_lower(cd_name) )THEN
2078         
2079            file_get_id=td_file(ji)%i_id
2080            EXIT
2081
2082         ENDIF
2083      ENDDO
2084
2085   END FUNCTION file_get_id
2086   !-------------------------------------------------------------------
2087   !> @brief
2088   !> This function get the next unused unit in array of file structure.
2089   !>
2090   !> @author J.Paul
2091   !> @date September, 2014 - Initial Version
2092   !
2093   !> @param[in] td_file   array of file
2094   !-------------------------------------------------------------------
2095   FUNCTION file_get_unit(td_file)
2096      IMPLICIT NONE
2097      ! Argument
2098      TYPE(TFILE), DIMENSION(:), INTENT(IN   ) :: td_file
2099
2100      ! function
2101      INTEGER(i4) :: file_get_unit
2102
2103      ! local variable
2104      ! loop indices
2105      !----------------------------------------------------------------
2106
2107      file_get_unit=MAXVAL(td_file(:)%i_id)+1
2108
2109   END FUNCTION file_get_unit
2110END MODULE file
2111
Note: See TracBrowser for help on using the repository browser.