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

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

update nemo trunk

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